Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
smradius
smradius
Commits
d82d2454
Commit
d82d2454
authored
May 16, 2019
by
Nigel Kukard
Browse files
Merge branch 'FUP' into 'master'
Added FUP support See merge request
!425
parents
71f628a0
f24d760c
Pipeline
#3767
passed with stages
in 4 minutes and 2 seconds
Changes
15
Pipelines
1
Hide whitespace changes
Inline
Side-by-side
FEATURES
View file @
d82d2454
...
...
@@ -27,7 +27,7 @@ Enhanced features:
* Plugin: Topups
* Plugin: Auto-topups
* Plugin: Usage/Time caps
* Plugin: Prepaid accounting based on usage/time
* Plugin: Prepaid accounting based on usage/time
* Plugin: Creation of accounting START records when no START record has been received but an interim update has - helps on slow/lossly links
* Plugin: Notifications, % based or approximate time based
* Plugin: User blacklists
...
...
TODO
View file @
d82d2454
...
...
@@ -5,8 +5,7 @@ smradiusd:
* Create a raddbpath config option which is prepended to dict paths
usage related queries:
* Use Math module to perform calculations
* Configurable 'use defaults for POD/CoA' we may not want to send these
smadmin:
* Ability to run smadmin before the end of current month and updating the records as necessary at a later stage
...
...
database/core.tsql
View file @
d82d2454
...
...
@@ -199,13 +199,13 @@ CREATE TABLE @PREFIX@accounting (
ServiceType @INT_UNSIGNED@,
FramedProtocol @INT_UNSIGNED@,
FramedProtocol @INT_UNSIGNED@,
NASPort VARCHAR(255),
NASPortType @INT_UNSIGNED@,
CallingStationID VARCHAR(255),
CallingStationID VARCHAR(255),
CalledStationID VARCHAR(255),
...
...
@@ -251,6 +251,9 @@ CREATE INDEX @PREFIX@accounting_idx2 ON @PREFIX@accounting (PeriodKey);
CREATE INDEX @PREFIX@accounting_idx4 ON @PREFIX@accounting (Username,AcctSessionID,NASIPAddress,NASPort);
/* accounting_update_query */
CREATE INDEX @PREFIX@accounting_idx5 ON @PREFIX@accounting (Username,AcctSessionID,NASIPAddress,NASPort,PeriodKey);
/* Index for the EventTimestamp */
CREATE INDEX @PREFIX@accounting_idx7 ON @PREFIX@accounting (EventTimestamp);
CREATE INDEX @PREFIX@accounting_idx8 ON @PREFIX@accounting (Username,EventTimestamp);
...
...
@@ -276,7 +279,7 @@ CREATE INDEX @PREFIX@accounting_summary_idx3 ON @PREFIX@accounting_summary (User
/* Users data */
CREATE TABLE @PREFIX@users_data (
ID
@SERIAL_TYPE@,
ID
@SERIAL_TYPE@,
UserID @INT_UNSIGNED@,
...
...
@@ -287,4 +290,4 @@ CREATE TABLE @PREFIX@users_data (
Value VARCHAR(255),
UNIQUE (UserID,Name)
) @CREATE_TABLE_SUFFIX@;
) @CREATE_TABLE_SUFFIX@;
lib/smradius/attributes.pm
View file @
d82d2454
...
...
@@ -81,6 +81,10 @@ my @attributeReplyIgnoreList = (
'
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
=
(
);
...
...
@@ -342,7 +346,7 @@ 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 i
t
endtical meaning, but the
# As a reply item, it has an i
d
endtical meaning, but the
# attribute is added to the reply items.
}
elsif
(
$operator
eq
'
+=
')
{
...
...
@@ -439,7 +443,7 @@ sub checkAcctAttribute
# 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 i
t
endtical meaning, but the
# As a reply item, it has an i
d
endtical meaning, but the
# attribute is added to the reply items.
if
(
$operator
eq
'
+=
')
{
...
...
@@ -546,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 i
t
endtical meaning, but for the reply items, instead of the request items.
# As a reply item, it has an i
d
endtical meaning, but for the reply items, instead of the request items.
}
elsif
(
$attribute
->
{'
Operator
'}
eq
'
:=
')
{
# Overwrite
...
...
@@ -561,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 i
t
endtical meaning, but the
# As a reply item, it has an i
d
endtical meaning, but the
# attribute is added to the reply items.
}
elsif
(
$attribute
->
{'
Operator
'}
eq
'
+=
')
{
...
...
@@ -610,7 +614,7 @@ sub setReplyVAttribute
@attrValues
=
(
$attribute
->
{'
Value
'}
);
}
$server
->
log
(
LOG_DEBUG
,"
[VATTRIBUTES] Processing REPLY attribute: '
"
.
$server
->
log
(
LOG_DEBUG
,"
[VATTRIBUTES] Processing REPLY
v
attribute: '
"
.
$attribute
->
{'
Name
'}
.
"
'
"
.
$attribute
->
{'
Operator
'}
.
"
'
"
.
join
("
','
",
@attrValues
)
.
"
'
");
...
...
@@ -640,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 i
t
endtical meaning, but for the reply items, instead of the request items.
# As a reply item, it has an i
d
endtical meaning, but for the reply items, instead of the request items.
}
elsif
(
$attribute
->
{'
Operator
'}
eq
'
:=
')
{
# Overwrite
...
...
@@ -655,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 i
t
endtical meaning, but the
# As a reply item, it has an i
d
endtical meaning, but the
# attribute is added to the reply items.
}
elsif
(
$attribute
->
{'
Operator
'}
eq
'
+=
')
{
...
...
@@ -707,7 +711,7 @@ sub processConfigAttribute
# 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 i
t
endtical meaning, but the
# As a reply item, it has an i
d
endtical meaning, but the
# attribute is added to the reply items.
if
(
$attribute
->
{'
Operator
'}
eq
'
+=
')
{
...
...
@@ -720,7 +724,7 @@ 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 i
t
endtical meaning, but for the reply items, instead of the request items.
# As a reply item, it has an i
d
endtical meaning, but for the reply items, instead of the request items.
}
elsif
(
$attribute
->
{'
Operator
'}
eq
'
:=
')
{
@
{
$configAttributes
->
{
$attribute
->
{'
Name
'}}}
=
@attrValues
;
...
...
@@ -790,7 +794,8 @@ sub processConditional
# Split off expression
my
(
$condition
,
$onTrue
,
$onFalse
)
=
(
$attrVal
=~
/^([^\?]*)(?:\?\s*((?:\S+)?[^:]*)(?:\s*\:\s*(.*))?)?$/
);
# 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
))
{
...
...
@@ -838,6 +843,10 @@ sub processConditional
$res
=
1
;
}
# Sanitize the output
$attribStr
=~
s/^\s*//
;
$attribStr
=~
s/\s*$//
;
$server
->
log
(
LOG_DEBUG
,"
[ATTRIBUTES] - Evaluated to '
$res
' returning '
"
.
(
defined
(
$attribStr
)
?
$attribStr
:
"
-undef-
")
.
"
'
");
# Loop with attributes:
...
...
lib/smradius/client.pm
View file @
d82d2454
# Radius client
# Copyright (C) 2007-201
6
, AllWorldIT
# Copyright (C) 2007-201
9
, 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
...
...
@@ -44,11 +44,15 @@ if (!eval {require Config::IniFiles; 1;}) {
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-201
6
, AllWorldIT
\n
");
print
(
STDERR
"
SMRadClient v
"
.
VERSION
.
"
- Copyright (c) 2007-201
9
, AllWorldIT
\n
");
print
(
STDERR
"
\n
");
...
...
@@ -67,10 +71,11 @@ sub run
\
%
{
$cmdline
},
"
config:s
",
"
raddb:s
",
"
listen:s
",
"
help
",
))
{
print
(
STDERR
"
ERROR: Error parsing commandline arguments
");
return
1
;
print
(
STDERR
"
ERROR: Error parsing commandline arguments
");
return
1
;
}
# Check for some args
...
...
@@ -190,13 +195,38 @@ sub run
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
"
\n
Response:
\n
");
...
...
@@ -216,7 +246,7 @@ sub run
# Read packet
$sock
->
recv
(
$udp_packet
,
65536
);
if
(
!
$udp_packet
)
{
print
(
STDERR
"
ERROR: Receive response data failed: $!
\n
");
print
(
STDERR
"
ERROR: Receive response data failed
on socket
: $!
\n
");
return
1
;
}
...
...
@@ -225,13 +255,44 @@ sub run
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
{
'
request
'
=>
$self
->
hashedPacket
(
$self
->
{'
packet
'}),
'
response
'
=>
$self
->
hashedPacket
(
$pkt
),
};
return
$ret
;
}
return
0
;
...
...
@@ -261,7 +322,7 @@ sub hashedPacket
foreach
my
$attrName
(
$pkt
->
vsattributes
(
$attrVendor
))
{
$res
->
{'
vattributes
'}
->
{
$attrVendor
}
->
{
$attrName
}
=
$pkt
->
vsattr
(
$attrVendor
,
$attrName
);
}
}
}
return
$res
;
}
...
...
lib/smradius/constants.pm
View file @
d82d2454
...
...
@@ -20,14 +20,13 @@
## @class smradius::constants
# SMRadius constants package
package
smradius::
constants
;
use
base
qw(Exporter)
;
use
strict
;
use
warnings
;
# Exporter stuff
use
base
qw(Exporter)
;
our
(
@EXPORT
,
@EXPORT_OK
);
@EXPORT
=
qw(
RES_OK
...
...
@@ -37,7 +36,7 @@ our (@EXPORT,@EXPORT_OK);
MOD_RES_NACK
MOD_RES_SKIP
UINT_MAX
GIGAWORD_VALUE
)
;
@EXPORT_OK
=
();
...
...
@@ -50,7 +49,7 @@ use constant {
MOD_RES_ACK
=>
1
,
MOD_RES_NACK
=>
2
,
UINT_MAX
=>
2
**
32
GIGAWORD_VALUE
=>
2
**
32
,
};
...
...
lib/smradius/daemon.pm
View file @
d82d2454
# Radius daemon
# Copyright (C) 2007-201
6
, AllWorldIT
# Copyright (C) 2007-201
9
, 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
...
...
@@ -898,109 +898,145 @@ sub process_request {
foreach
my
$attrOp
(
keys
%
{
$user
->
{'
Attributes
'}
->
{
$attrName
}})
{
# Grab attribute
my
$attr
=
$user
->
{'
Attributes
'}
->
{
$attrName
}
->
{
$attrOp
};
# Check attribute against accounting attributes
attributes
# Check attribute against accounting attributes
my
$res
=
checkAcctAttribute
(
$self
,
$user
,
$acctAttributes
,
$attr
);
# We don't care if it fails
}
}
# Check if we must POD the user
# The coaReq may be either POD or CoA
my
$coaReq
=
smradius::Radius::
Packet
->
new
(
$self
->
{'
radius
'}
->
{'
dictionary
'});
# Set packet identifier
$coaReq
->
set_identifier
(
$$
&
0xff
);
# 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
);
}
my
$resp
=
smradius::Radius::
Packet
->
new
(
$self
->
{'
radius
'}
->
{'
dictionary
'});
# 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
'));
$resp
->
set_code
('
Disconnect-Request
');
my
$id
=
$$
&
0xff
;
$resp
->
set_identifier
(
$id
);
$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
'));
# Add onto logline
$request
->
addLogLine
("
. REPLY =>
");
foreach
my
$attrName
(
$resp
->
attributes
)
{
$request
->
addLogLine
(
"
%s: '%s'
",
$attrName
,
$resp
->
rawattr
(
$attrName
)
);
# 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
;
}
# Grab packet
my
$response
=
auth_resp
(
$resp
->
pack
,
getAttributeValue
(
$user
->
{'
ConfigAttributes
'},"
SMRadius-Config-Secret
"));
# Check for POD Servers and send disconnect
if
(
defined
(
$user
->
{'
ConfigAttributes
'}
->
{'
SMRadius-Config-PODServer
'}))
{
$self
->
log
(
LOG_DEBUG
,"
[SMRADIUS] SMRadius-Config-PODServer is defined
");
# Check address format
foreach
my
$podServerAttribute
(
@
{
$user
->
{'
ConfigAttributes
'}
->
{'
SMRadius-Config-PODServer
'}})
{
# Check for valid IP
if
(
$podServerAttribute
=~
/^([0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3})/
)
{
my
$podServer
=
$
1
;
# If we have a port, use it, otherwise use default 1700
my
$podServerPort
;
if
(
$podServerAttribute
=~
/:([0-9]+)$/
)
{
$podServerPort
=
$
1
;
}
else
{
$podServerPort
=
1700
;
}
$self
->
log
(
LOG_DEBUG
,"
[SMRADIUS] POST-ACCT: Trying PODServer => IP: '
"
.
$podServer
.
"
' Port: '
"
.
$podServerPort
.
"
'
");
# Create socket to send packet out on
my
$podServerTimeout
=
"
10
";
# 10 second timeout
my
$podSock
=
IO::Socket::
INET
->
new
(
PeerAddr
=>
$podServer
,
PeerPort
=>
$podServerPort
,
Type
=>
SOCK_DGRAM
,
Proto
=>
'
udp
',
TimeOut
=>
$podServerTimeout
,
);
if
(
!
$podSock
)
{
$self
->
log
(
LOG_ERR
,"
[SMRADIUS] POST-ACCT: Failed to create socket to send POD on
");
next
;
}
# Check if we sent the packet...
if
(
!
$podSock
->
send
(
$response
))
{
$self
->
log
(
LOG_ERR
,"
[SMRADIUS] POST-ACCT: Failed to send data on socket
");
next
;
}
# Once sent, we need to get a response back
my
$sh
=
IO::
Select
->
new
(
$podSock
);
if
(
!
$sh
)
{
$self
->
log
(
LOG_ERR
,"
[SMRADIUS] POST-ACCT: Failed to select data on socket
");
next
;
}
if
(
!
$sh
->
can_read
(
$podServerTimeout
))
{
$self
->
log
(
LOG_ERR
,"
[SMRADIUS] POST-ACCT: Failed to receive data on socket
");
next
;
}
my
$data
;
$podSock
->
recv
(
$data
,
65536
);
if
(
!
$data
)
{
$self
->
log
(
LOG_ERR
,"
[SMRADIUS] POST-ACCT: Receive data failed
");
$logReason
=
"
POD Failure
";
}
else
{
$logReason
=
"
User POD
";
}
#my @stuff = unpack('C C n a16 a*', $data);
#$self->log(LOG_DEBUG,"STUFF: ".Dumper(\@stuff));
}
else
{
$self
->
log
(
LOG_DEBUG
,"
[SMRADIUS] Invalid POD Server value: '
"
.
$podServerAttribute
.
"
'
");
}
}
# 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
=>
$coaServerTimeout
,
);
if
(
!
$coaSock
)
{
$self
->
log
(
LOG_ERR
,"
[SMRADIUS] POST-ACCT: Failed to create socket to send CoA on: $!
");
next
;
}
# 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
;
}
# 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
;
}
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
': $!
");
$logReason
=
"
No Response
";
next
;
}
# Parse the radius packet
my
$coaRes
=
smradius::Radius::
Packet
->
new
(
$self
->
{'
radius
'}
->
{'
dictionary
'},
$coaRes_packet
);
# Check status
if
(
$coaRes
->
code
eq
"
CoA-ACK
")
{
$logReason
=
"
CoA Success
";
last
;
}
elsif
(
$coaRes
->
code
eq
"
CoA-NACK
")
{
$logReason
=
"
CoA Fail
";
}
elsif
(
$coaRes
->
code
eq
"
Disconnect-ACK
")
{
$logReason
=
"
POD Success
";
last
;
}
elsif
(
$coaRes
->
code
eq
"
Disconnect-NACK
")
{
$logReason
=
"
POD Fail
";
}
else
{
$
self
->
log
(
LOG_DEBUG
,"
[SMRADIUS] SMRadius-Config-PODServer is not defined
")
;
$
logReason
=
"
CoA/POD Fail
"
;
}
}
...
...
@@ -1154,133 +1190,8 @@ sub process_request {
$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
$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
$resp
->
set_attr
(
$attrName
,
$value
);
}
else
{
$request
->
addLogLine
("
%s
",
$attrName
);