raddb/mods-config/perl/example.pl

   1
   2 #
   3 #  This program is free software; you can redistribute it and/or modify
   4 #  it under the terms of the GNU General Public License as published by
   5 #  the Free Software Foundation; either version 2 of the License, or
   6 #  (at your option) any later version.
   7 #
   8 #  This program is distributed in the hope that it will be useful,
   9 #  but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 #  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 #  GNU General Public License for more details.
  12 #
  13 #  You should have received a copy of the GNU General Public License
  14 #  along with this program; if not, write to the Free Software
  15 #  Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA
  16 #
  17 #  Copyright 2002  The FreeRADIUS server project
  18 #  Copyright 2002  Boian Jordanov <bjordanov@orbitel.bg>
  19 #
  20
  21 #
  22 # Example code for use with rlm_perl
  23 #
  24 # You can use every module that comes with your perl distribution!
  25 #
  26 # If you are using DBI and do some queries to DB, please be sure to
  27 # use the CLONE function to initialize the DBI connection to DB.
  28 #
  29
  30 use strict;
  31 use warnings;
  32
  33 # use ...
  34 use Data::Dumper;
  35
  36 # Bring the global hashes into the package scope
  37 our (%RAD_REQUEST, %RAD_REPLY, %RAD_CHECK, %RAD_STATE);
  38
  39 # This is hash wich hold original request from radius
  40 #my %RAD_REQUEST;
  41 # In this hash you add values that will be returned to NAS.
  42 #my %RAD_REPLY;
  43 #This is for check items
  44 #my %RAD_CHECK;
  45 # This is the session-sate
  46 #my %RAD_STATE;
  47 # This is configuration items from "config" perl module configuration section
  48 #my %RAD_PERLCONF;
  49
  50 # Multi-value attributes are mapped to perl arrayrefs.
  51 #
  52 #  update request {
  53 #    Filter-Id := 'foo'
  54 #    Filter-Id += 'bar'
  55 #  }
  56 #
  57 # This results to the following entry in %RAD_REQUEST:
  58 #
  59 #  $RAD_REQUEST{'Filter-Id'} = [ 'foo', 'bar' ];
  60 #
  61 # Likewise, you can assign an arrayref to return multi-value attributes
  62
  63 #
  64 # This the remapping of return values
  65 #
  66 use constant {
  67         RLM_MODULE_REJECT   => 0, # immediately reject the request
  68         RLM_MODULE_OK       => 2, # the module is OK, continue
  69         RLM_MODULE_HANDLED  => 3, # the module handled the request, so stop
  70         RLM_MODULE_INVALID  => 4, # the module considers the request invalid
  71         RLM_MODULE_USERLOCK => 5, # reject the request (user is locked out)
  72         RLM_MODULE_NOTFOUND => 6, # user not found
  73         RLM_MODULE_NOOP     => 7, # module succeeded without doing anything
  74         RLM_MODULE_UPDATED  => 8, # OK (pairs modified)
  75         RLM_MODULE_NUMCODES => 9  # How many return codes there are
  76 };
  77
  78 # Same as src/include/radiusd.h
  79 use constant    L_DBG=>   1;
  80 use constant    L_AUTH=>  2;
  81 use constant    L_INFO=>  3;
  82 use constant    L_ERR=>   4;
  83 use constant    L_PROXY=> 5;
  84 use constant    L_ACCT=>  6;
  85
  86 #  Global variables can persist across different calls to the module.
  87 #
  88 #
  89 #       {
  90 #        my %static_global_hash = ();
  91 #
  92 #               sub post_auth {
  93 #               ...
  94 #               }
  95 #               ...
  96 #       }
  97
  98
  99 # Function to handle authorize
 100 sub authorize {
 101         # For debugging purposes only
 102 #       &log_request_attributes;
 103
 104         # Here's where your authorization code comes
 105         # You can call another function from here:
 106         &test_call;
 107
 108         return RLM_MODULE_OK;
 109 }
 110
 111 # Function to handle authenticate
 112 sub authenticate {
 113         # For debugging purposes only
 114 #       &log_request_attributes;
 115
 116         if ($RAD_REQUEST{'User-Name'} =~ /^baduser/i) {
 117                 # Reject user and tell him why
 118                 $RAD_REPLY{'Reply-Message'} = "Denied access by rlm_perl function";
 119                 return RLM_MODULE_REJECT;
 120         } else {
 121                 # Accept user and set some attribute
 122                 $RAD_REPLY{'h323-credit-amount'} = "100";
 123                 return RLM_MODULE_OK;
 124         }
 125 }
 126
 127 # Function to handle preacct
 128 sub preacct {
 129         # For debugging purposes only
 130 #       &log_request_attributes;
 131
 132         return RLM_MODULE_OK;
 133 }
 134
 135 # Function to handle accounting
 136 sub accounting {
 137         # For debugging purposes only
 138 #       &log_request_attributes;
 139
 140         # You can call another subroutine from here
 141         &test_call;
 142
 143         return RLM_MODULE_OK;
 144 }
 145
 146 # Function to handle checksimul
 147 sub checksimul {
 148         # For debugging purposes only
 149 #       &log_request_attributes;
 150
 151         return RLM_MODULE_OK;
 152 }
 153
 154 # Function to handle pre_proxy
 155 sub pre_proxy {
 156         # For debugging purposes only
 157 #       &log_request_attributes;
 158
 159         return RLM_MODULE_OK;
 160 }
 161
 162 # Function to handle post_proxy
 163 sub post_proxy {
 164         # For debugging purposes only
 165 #       &log_request_attributes;
 166
 167         return RLM_MODULE_OK;
 168 }
 169
 170 # Function to handle post_auth
 171 sub post_auth {
 172         # For debugging purposes only
 173 #       &log_request_attributes;
 174
 175         return RLM_MODULE_OK;
 176 }
 177
 178 # Function to handle xlat
 179 sub xlat {
 180         # For debugging purposes only
 181 #       &log_request_attributes;
 182
 183         # Loads some external perl and evaluate it
 184         my ($filename,$a,$b,$c,$d) = @_;
 185         &radiusd::radlog(L_DBG, "From xlat $filename ");
 186         &radiusd::radlog(L_DBG,"From xlat $a $b $c $d ");
 187         local *FH;
 188         open FH, $filename or die "open '$filename' $!";
 189         local($/) = undef;
 190         my $sub = <FH>;
 191         close FH;
 192         my $eval = qq{ sub handler{ $sub;} };
 193         eval $eval;
 194         eval {main->handler;};
 195 }
 196
 197 # Function to handle detach
 198 sub detach {
 199         # For debugging purposes only
 200 #       &log_request_attributes;
 201 }
 202
 203 #
 204 # Some functions that can be called from other functions
 205 #
 206
 207 sub test_call {
 208         # Some code goes here
 209 }
 210
 211 sub log_request_attributes {
 212         # This shouldn't be done in production environments!
 213         # This is only meant for debugging!
 214         for (keys %RAD_REQUEST) {
 215                 &radiusd::radlog(L_DBG, "RAD_REQUEST: $_ = $RAD_REQUEST{$_}");
 216         }
 217 }
 218