Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
10
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Open sidebar
smradius
smradius
Commits
d82d2454
Commit
d82d2454
authored
May 16, 2019
by
Nigel Kukard
Browse files
Options
Browse Files
Download
Plain Diff
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
Showing
15 changed files
with
1085 additions
and
311 deletions
+1085
-311
FEATURES
FEATURES
+1
-1
TODO
TODO
+1
-2
database/core.tsql
database/core.tsql
+7
-4
lib/smradius/attributes.pm
lib/smradius/attributes.pm
+19
-10
lib/smradius/client.pm
lib/smradius/client.pm
+72
-11
lib/smradius/constants.pm
lib/smradius/constants.pm
+3
-4
lib/smradius/daemon.pm
lib/smradius/daemon.pm
+251
-219
lib/smradius/modules/accounting/mod_accounting_sql.pm
lib/smradius/modules/accounting/mod_accounting_sql.pm
+84
-32
lib/smradius/modules/features/mod_feature_capping.pm
lib/smradius/modules/features/mod_feature_capping.pm
+9
-9
lib/smradius/modules/features/mod_feature_fup.pm
lib/smradius/modules/features/mod_feature_fup.pm
+355
-0
lib/smradius/modules/features/mod_feature_user_stats.pm
lib/smradius/modules/features/mod_feature_user_stats.pm
+17
-0
lib/smradius/modules/system/mod_config_sql_topups.pm
lib/smradius/modules/system/mod_config_sql_topups.pm
+2
-2
lib/smradius/util.pm
lib/smradius/util.pm
+4
-3
smradiusd.conf
smradiusd.conf
+2
-1
t/200-dbtests.t
t/200-dbtests.t
+258
-13
No files found.
FEATURES
View file @
d82d2454
...
@@ -27,7 +27,7 @@ Enhanced features:
...
@@ -27,7 +27,7 @@ Enhanced features:
* Plugin: Topups
* Plugin: Topups
* Plugin: Auto-topups
* Plugin: Auto-topups
* Plugin: Usage/Time caps
* 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: 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: Notifications, % based or approximate time based
* Plugin: User blacklists
* Plugin: User blacklists
...
...
TODO
View file @
d82d2454
...
@@ -5,8 +5,7 @@ smradiusd:
...
@@ -5,8 +5,7 @@ smradiusd:
* Create a raddbpath config option which is prepended to dict paths
* Create a raddbpath config option which is prepended to dict paths
usage related queries:
* Configurable 'use defaults for POD/CoA' we may not want to send these
* Use Math module to perform calculations
smadmin:
smadmin:
* Ability to run smadmin before the end of current month and updating the records as necessary at a later stage
* 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 (
...
@@ -199,13 +199,13 @@ CREATE TABLE @PREFIX@accounting (
ServiceType @INT_UNSIGNED@,
ServiceType @INT_UNSIGNED@,
FramedProtocol @INT_UNSIGNED@,
FramedProtocol @INT_UNSIGNED@,
NASPort VARCHAR(255),
NASPort VARCHAR(255),
NASPortType @INT_UNSIGNED@,
NASPortType @INT_UNSIGNED@,
CallingStationID VARCHAR(255),
CallingStationID VARCHAR(255),
CalledStationID VARCHAR(255),
CalledStationID VARCHAR(255),
...
@@ -251,6 +251,9 @@ CREATE INDEX @PREFIX@accounting_idx2 ON @PREFIX@accounting (PeriodKey);
...
@@ -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);
CREATE INDEX @PREFIX@accounting_idx4 ON @PREFIX@accounting (Username,AcctSessionID,NASIPAddress,NASPort);
/* accounting_update_query */
/* accounting_update_query */
CREATE INDEX @PREFIX@accounting_idx5 ON @PREFIX@accounting (Username,AcctSessionID,NASIPAddress,NASPort,PeriodKey);
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
...
@@ -276,7 +279,7 @@ CREATE INDEX @PREFIX@accounting_summary_idx3 ON @PREFIX@accounting_summary (User
/* Users data */
/* Users data */
CREATE TABLE @PREFIX@users_data (
CREATE TABLE @PREFIX@users_data (
ID
@SERIAL_TYPE@,
ID
@SERIAL_TYPE@,
UserID @INT_UNSIGNED@,
UserID @INT_UNSIGNED@,
...
@@ -287,4 +290,4 @@ CREATE TABLE @PREFIX@users_data (
...
@@ -287,4 +290,4 @@ CREATE TABLE @PREFIX@users_data (
Value VARCHAR(255),
Value VARCHAR(255),
UNIQUE (UserID,Name)
UNIQUE (UserID,Name)
) @CREATE_TABLE_SUFFIX@;
) @CREATE_TABLE_SUFFIX@;
lib/smradius/attributes.pm
View file @
d82d2454
...
@@ -81,6 +81,10 @@ my @attributeReplyIgnoreList = (
...
@@ -81,6 +81,10 @@ my @attributeReplyIgnoreList = (
'
SMRadius-AutoTopup-Uptime-Notify
',
'
SMRadius-AutoTopup-Uptime-Notify
',
'
SMRadius-AutoTopup-Uptime-NotifyTemplate
',
'
SMRadius-AutoTopup-Uptime-NotifyTemplate
',
'
SMRadius-AutoTopup-Uptime-Threshold
',
'
SMRadius-AutoTopup-Uptime-Threshold
',
'
SMRadius-Config-Filter-Reply-Attribute
',
'
SMRadius-Config-Filter-Reply-VAttribute
',
'
SMRadius-FUP-Period
',
'
SMRadius-FUP-Traffic-Threshold
',
);
);
my
@attributeVReplyIgnoreList
=
(
my
@attributeVReplyIgnoreList
=
(
);
);
...
@@ -342,7 +346,7 @@ sub checkAuthAttribute
...
@@ -342,7 +346,7 @@ sub checkAuthAttribute
# Always matches as a check item, and adds the current
# Always matches as a check item, and adds the current
# attribute with value to the list of configuration items.
# 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.
# attribute is added to the reply items.
}
elsif
(
$operator
eq
'
+=
')
{
}
elsif
(
$operator
eq
'
+=
')
{
...
@@ -439,7 +443,7 @@ sub checkAcctAttribute
...
@@ -439,7 +443,7 @@ sub checkAcctAttribute
# Always matches as a check item, and adds the current
# Always matches as a check item, and adds the current
# attribute with value to the list of configuration items.
# 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.
# attribute is added to the reply items.
if
(
$operator
eq
'
+=
')
{
if
(
$operator
eq
'
+=
')
{
...
@@ -546,7 +550,7 @@ sub setReplyAttribute
...
@@ -546,7 +550,7 @@ sub setReplyAttribute
# Always matches as a check item, and replaces in the configuration items any attribute of the same name.
# 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.
# 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
'
:=
')
{
}
elsif
(
$attribute
->
{'
Operator
'}
eq
'
:=
')
{
# Overwrite
# Overwrite
...
@@ -561,7 +565,7 @@ sub setReplyAttribute
...
@@ -561,7 +565,7 @@ sub setReplyAttribute
# Always matches as a check item, and adds the current
# Always matches as a check item, and adds the current
# attribute with value to the list of configuration items.
# 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.
# attribute is added to the reply items.
}
elsif
(
$attribute
->
{'
Operator
'}
eq
'
+=
')
{
}
elsif
(
$attribute
->
{'
Operator
'}
eq
'
+=
')
{
...
@@ -610,7 +614,7 @@ sub setReplyVAttribute
...
@@ -610,7 +614,7 @@ sub setReplyVAttribute
@attrValues
=
(
$attribute
->
{'
Value
'}
);
@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
)
.
"
'
");
$attribute
->
{'
Name
'}
.
"
'
"
.
$attribute
->
{'
Operator
'}
.
"
'
"
.
join
("
','
",
@attrValues
)
.
"
'
");
...
@@ -640,7 +644,7 @@ sub setReplyVAttribute
...
@@ -640,7 +644,7 @@ sub setReplyVAttribute
# Always matches as a check item, and replaces in the configuration items any attribute of the same name.
# 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.
# 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
'
:=
')
{
}
elsif
(
$attribute
->
{'
Operator
'}
eq
'
:=
')
{
# Overwrite
# Overwrite
...
@@ -655,7 +659,7 @@ sub setReplyVAttribute
...
@@ -655,7 +659,7 @@ sub setReplyVAttribute
# Always matches as a check item, and adds the current
# Always matches as a check item, and adds the current
# attribute with value to the list of configuration items.
# 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.
# attribute is added to the reply items.
}
elsif
(
$attribute
->
{'
Operator
'}
eq
'
+=
')
{
}
elsif
(
$attribute
->
{'
Operator
'}
eq
'
+=
')
{
...
@@ -707,7 +711,7 @@ sub processConfigAttribute
...
@@ -707,7 +711,7 @@ sub processConfigAttribute
# Always matches as a check item, and adds the current
# Always matches as a check item, and adds the current
# attribute with value to the list of configuration items.
# 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.
# attribute is added to the reply items.
if
(
$attribute
->
{'
Operator
'}
eq
'
+=
')
{
if
(
$attribute
->
{'
Operator
'}
eq
'
+=
')
{
...
@@ -720,7 +724,7 @@ sub processConfigAttribute
...
@@ -720,7 +724,7 @@ sub processConfigAttribute
# Always matches as a check item, and replaces in the configuration items any attribute of the same name.
# 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.
# 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
'
:=
')
{
}
elsif
(
$attribute
->
{'
Operator
'}
eq
'
:=
')
{
@
{
$configAttributes
->
{
$attribute
->
{'
Name
'}}}
=
@attrValues
;
@
{
$configAttributes
->
{
$attribute
->
{'
Name
'}}}
=
@attrValues
;
...
@@ -790,7 +794,8 @@ sub processConditional
...
@@ -790,7 +794,8 @@ sub processConditional
# Split off expression
# 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 there is no condition we cannot really continue?
if
(
!
defined
(
$condition
))
{
if
(
!
defined
(
$condition
))
{
...
@@ -838,6 +843,10 @@ sub processConditional
...
@@ -838,6 +843,10 @@ sub processConditional
$res
=
1
;
$res
=
1
;
}
}
# Sanitize the output
$attribStr
=~
s/^\s*//
;
$attribStr
=~
s/\s*$//
;
$server
->
log
(
LOG_DEBUG
,"
[ATTRIBUTES] - Evaluated to '
$res
' returning '
"
.
(
defined
(
$attribStr
)
?
$attribStr
:
"
-undef-
")
.
"
'
");
$server
->
log
(
LOG_DEBUG
,"
[ATTRIBUTES] - Evaluated to '
$res
' returning '
"
.
(
defined
(
$attribStr
)
?
$attribStr
:
"
-undef-
")
.
"
'
");
# Loop with attributes:
# Loop with attributes:
...
...
lib/smradius/client.pm
View file @
d82d2454
# Radius client
# 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
# 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
# it under the terms of the GNU General Public License as published by
...
@@ -44,11 +44,15 @@ if (!eval {require Config::IniFiles; 1;}) {
...
@@ -44,11 +44,15 @@ if (!eval {require Config::IniFiles; 1;}) {
sub
run
sub
run
{
{
my
(
$self
,
@methodArgs
)
=
@_
;
my
(
$self
,
@methodArgs
)
=
@_
;
# Instantiate if we're not already instantiated
# Instantiate if we're not already instantiated
$self
=
$self
->
new
()
if
(
!
ref
(
$self
));
$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
");
print
(
STDERR
"
\n
");
...
@@ -67,10 +71,11 @@ sub run
...
@@ -67,10 +71,11 @@ sub run
\
%
{
$cmdline
},
\
%
{
$cmdline
},
"
config:s
",
"
config:s
",
"
raddb:s
",
"
raddb:s
",
"
listen:s
",
"
help
",
"
help
",
))
{
))
{
print
(
STDERR
"
ERROR: Error parsing commandline arguments
");
print
(
STDERR
"
ERROR: Error parsing commandline arguments
");
return
1
;
return
1
;
}
}
# Check for some args
# Check for some args
...
@@ -190,13 +195,38 @@ sub run
...
@@ -190,13 +195,38 @@ sub run
return
1
;
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...
# Check if we sent the packet...
if
(
!
$sock
->
send
(
$udp_packet
))
{
if
(
!
$sock
->
send
(
$udp_packet
))
{
print
(
STDERR
"
ERROR: Failed to send data on socket
\n
");
print
(
STDERR
"
ERROR: Failed to send data on socket
\n
");
return
1
;
return
1
;
}
}
# And time for the response
# And time for the response
print
(
STDERR
"
\n
Response:
\n
");
print
(
STDERR
"
\n
Response:
\n
");
...
@@ -216,7 +246,7 @@ sub run
...
@@ -216,7 +246,7 @@ sub run
# Read packet
# Read packet
$sock
->
recv
(
$udp_packet
,
65536
);
$sock
->
recv
(
$udp_packet
,
65536
);
if
(
!
$udp_packet
)
{
if
(
!
$udp_packet
)
{
print
(
STDERR
"
ERROR: Receive response data failed: $!
\n
");
print
(
STDERR
"
ERROR: Receive response data failed
on socket
: $!
\n
");
return
1
;
return
1
;
}
}
...
@@ -225,13 +255,44 @@ sub run
...
@@ -225,13 +255,44 @@ sub run
print
(
STDERR
"
> Authenticated:
"
.
(
defined
(
auth_req_verify
(
$udp_packet
,
$self
->
{'
secret
'},
$authen
))
?
"
yes
"
:
"
no
")
.
"
\n
");
print
(
STDERR
"
> Authenticated:
"
.
(
defined
(
auth_req_verify
(
$udp_packet
,
$self
->
{'
secret
'},
$authen
))
?
"
yes
"
:
"
no
")
.
"
\n
");
print
(
STDERR
$pkt
->
str_dump
());
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 we were called as a function, return hashed version of the response packet
if
(
@methodArgs
)
{
if
(
@methodArgs
)
{
return
{
return
$ret
;
'
request
'
=>
$self
->
hashedPacket
(
$self
->
{'
packet
'}),
'
response
'
=>
$self
->
hashedPacket
(
$pkt
),
};
}
}
return
0
;
return
0
;
...
@@ -261,7 +322,7 @@ sub hashedPacket
...
@@ -261,7 +322,7 @@ sub hashedPacket
foreach
my
$attrName
(
$pkt
->
vsattributes
(
$attrVendor
))
{
foreach
my
$attrName
(
$pkt
->
vsattributes
(
$attrVendor
))
{
$res
->
{'
vattributes
'}
->
{
$attrVendor
}
->
{
$attrName
}
=
$pkt
->
vsattr
(
$attrVendor
,
$attrName
);
$res
->
{'
vattributes
'}
->
{
$attrVendor
}
->
{
$attrName
}
=
$pkt
->
vsattr
(
$attrVendor
,
$attrName
);
}
}
}
}
return
$res
;
return
$res
;
}
}
...
...
lib/smradius/constants.pm
View file @
d82d2454
...
@@ -20,14 +20,13 @@
...
@@ -20,14 +20,13 @@
## @class smradius::constants
## @class smradius::constants
# SMRadius constants package
# SMRadius constants package
package
smradius::
constants
;
package
smradius::
constants
;
use
base
qw(Exporter)
;
use
strict
;
use
strict
;
use
warnings
;
use
warnings
;
# Exporter stuff
use
base
qw(Exporter)
;
our
(
@EXPORT
,
@EXPORT_OK
);
our
(
@EXPORT
,
@EXPORT_OK
);
@EXPORT
=
qw(
@EXPORT
=
qw(
RES_OK
RES_OK
...
@@ -37,7 +36,7 @@ our (@EXPORT,@EXPORT_OK);
...
@@ -37,7 +36,7 @@ our (@EXPORT,@EXPORT_OK);
MOD_RES_NACK
MOD_RES_NACK
MOD_RES_SKIP
MOD_RES_SKIP
UINT_MAX
GIGAWORD_VALUE
)
;
)
;
@EXPORT_OK
=
();
@EXPORT_OK
=
();
...
@@ -50,7 +49,7 @@ use constant {
...
@@ -50,7 +49,7 @@ use constant {
MOD_RES_ACK
=>
1
,
MOD_RES_ACK
=>
1
,
MOD_RES_NACK
=>
2
,
MOD_RES_NACK
=>
2
,
UINT_MAX
=>
2
**
32
GIGAWORD_VALUE
=>
2
**
32
,
};
};
...
...
lib/smradius/daemon.pm
View file @
d82d2454
# Radius daemon
# 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
# 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
# it under the terms of the GNU General Public License as published by
...
@@ -898,109 +898,145 @@ sub process_request {
...
@@ -898,109 +898,145 @@ sub process_request {
foreach
my
$attrOp
(
keys
%
{
$user
->
{'
Attributes
'}
->
{
$attrName
}})
{
foreach
my
$attrOp
(
keys
%
{
$user
->
{'
Attributes
'}
->
{
$attrName
}})
{
# Grab attribute
# Grab attribute
my
$attr
=
$user
->
{'
Attributes
'}
->
{
$attrName
}
->
{
$attrOp
};
my
$attr
=
$user
->
{'
Attributes
'}
->
{
$attrName
}
->
{
$attrOp
};
# Check attribute against accounting attributes
attributes
# Check attribute against accounting attributes
my
$res
=
checkAcctAttribute
(
$self
,
$user
,
$acctAttributes
,
$attr
);
my
$res
=
checkAcctAttribute
(
$self
,
$user
,
$acctAttributes
,
$attr
);
# We don't care if it fails
# 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
)
{
if
(
$PODUser
)
{
$self
->
log
(
LOG_DEBUG
,"
[SMRADIUS] POST-ACCT: Trying to disconnect user...
");
$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
');
# Add onto logline
my
$id
=
$$
&
0xff
;
$request
->
addLogLine
("
. REPLY =>
");
$resp
->
set_identifier
(
$id
);
foreach
my
$attrName
(
$coaReq
->
attributes
)
{
$request
->
addLogLine
(
$resp
->
set_attr
('
User-Name
',
$pkt
->
attr
('
User-Name
'));
"
%s: '%s'
",
$resp
->
set_attr
('
Framed-IP-Address
',
$pkt
->
attr
('
Framed-IP-Address
'));
$attrName
,
$resp
->
set_attr
('
NAS-IP-Address
',
$pkt
->
attr
('
NAS-IP-Address
'));
$coaReq
->
rawattr
(
$attrName
)
);
# Add onto logline
}
$request
->
addLogLine
("
. REPLY =>
");
foreach
my
$attrName
(
$resp
->
attributes
)
{
# Generate coaReq packet
$request
->
addLogLine
(
my
$coaReq_packet
=
auth_resp
(
$coaReq
->
pack
,
getAttributeValue
(
$user
->
{'
ConfigAttributes
'},"
SMRadius-Config-Secret
"));
"
%s: '%s'
",
$attrName
,
# Array CoA servers to contact
$resp
->
rawattr
(
$attrName
)
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
# Set default CoA server port
my
$response
=
auth_resp
(
$resp
->
pack
,
getAttributeValue
(
$user
->
{'
ConfigAttributes
'},"
SMRadius-Config-Secret
"));
$coaServerPort
//
=
1700
;
# Check for POD Servers and send disconnect
$self
->
log
(
LOG_DEBUG
,"
[SMRADIUS] POST-ACCT: Trying CoAServer => IP: '
"
.
$coaServer
.
"
' Port: '
"
.
$coaServerPort
.
"
'
");
if
(
defined
(
$user
->
{'
ConfigAttributes
'}
->
{'
SMRadius-Config-PODServer
'}))
{
$self
->
log
(
LOG_DEBUG
,"
[SMRADIUS] SMRadius-Config-PODServer is defined
");
# Create socket to send packet out on
my
$coaServerTimeout
=
"
2
";
# 2 second timeout
# Check address format
my
$coaSock
=
IO::Socket::
INET
->
new
(
foreach
my
$podServerAttribute
(
@
{
$user
->
{'
ConfigAttributes
'}
->
{'
SMRadius-Config-PODServer
'}})
{
PeerAddr
=>
$coaServerIP
,
# Check for valid IP
PeerPort
=>
$coaServerPort
,