src/modules/rlm_perl/rlm_perl.c

   1 /*
   2  * rlm_perl.c
   3  *
   4  * Version:    $Id$
   5  *
   6  *   This program is free software; you can redistribute it and/or modify
   7  *   it under the terms of the GNU General Public License as published by
   8  *   the Free Software Foundation; either version 2 of the License, or
   9  *   (at your option) any later version.
  10  *
  11  *   This program is distributed in the hope that it will be useful,
  12  *   but WITHOUT ANY WARRANTY; without even the implied warranty of
  13  *   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14  *   GNU General Public License for more details.
  15  *
  16  *   You should have received a copy of the GNU General Public License
  17  *   along with this program; if not, write to the Free Software
  18  *   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  19  *
  20  * Copyright 2002  The FreeRADIUS server project
  21  * Copyright 2002  Boian Jordanov <bjordanov@orbitel.bg>
  22  */
  23
  24 #include "autoconf.h"
  25 #include "libradius.h"
  26
  27 #include <stdio.h>
  28 #include <stdlib.h>
  29 #include <string.h>
  30
  31 #include "radiusd.h"
  32 #include "modules.h"
  33 #include "conffile.h"
  34
  35 #ifdef DEBUG
  36 #undef DEBUG
  37 #endif
  38
  39 #ifdef INADDR_ANY
  40 #undef INADDR_ANY
  41 #endif
  42
  43 #ifdef INADDR_NONE
  44 #undef INADDR_NONE
  45 #endif
  46
  47 #include <EXTERN.h>
  48 #include <perl.h>
  49 #include <XSUB.h>
  50
  51 #ifndef DO_CLEAN
  52 #define DO_CLEAN 0
  53 #endif
  54
  55 static const char rcsid[] = "$Id$";
  56
  57 /*
  58  *      Define a structure for our module configuration.
  59  *
  60  *      These variables do not need to be in a structure, but it's
  61  *      a lot cleaner to do so, and a pointer to the structure can
  62  *      be used as the instance handle.
  63  */
  64 typedef struct perl_inst {
  65         /* Name of the perl module */
  66         char    *module;
  67
  68         /* Name of the functions for each module method */
  69         char    *func_authorize;
  70         char    *func_authenticate;
  71         char    *func_accounting;
  72         char    *func_preacct;
  73         char    *func_checksimul;
  74         char    *func_detach;
  75         char    *func_xlat;
  76         char    *xlat_name;
  77
  78         HV      *rad_reply_hv;
  79         HV      *rad_check_hv;
  80         HV      *rad_request_hv;
  81 } PERL_INST;
  82
  83 /*
  84  *      A mapping of configuration file names to internal variables.
  85  *
  86  *      Note that the string is dynamically allocated, so it MUST
  87  *      be freed.  When the configuration file parse re-reads the string,
  88  *      it free's the old one, and strdup's the new one, placing the pointer
  89  *      to the strdup'd string into 'config.string'.  This gets around
  90  *      buffer over-flows.
  91  */
  92 static CONF_PARSER module_config[] = {
  93         { "module",  PW_TYPE_STRING_PTR,
  94           offsetof(PERL_INST,module), NULL,  "module"},
  95         { "func_authorize", PW_TYPE_STRING_PTR,
  96           offsetof(PERL_INST,func_authorize), NULL, "authorize"},
  97         { "func_authenticate", PW_TYPE_STRING_PTR,
  98           offsetof(PERL_INST,func_authenticate), NULL, "authenticate"},
  99         { "func_accounting", PW_TYPE_STRING_PTR,
 100           offsetof(PERL_INST,func_accounting), NULL, "accounting"},
 101         { "func_preacct", PW_TYPE_STRING_PTR,
 102           offsetof(PERL_INST,func_preacct), NULL, "preacct"},
 103         { "func_checksimul", PW_TYPE_STRING_PTR,
 104           offsetof(PERL_INST,func_checksimul), NULL, "checksimul"},
 105         { "func_detach", PW_TYPE_STRING_PTR,
 106           offsetof(PERL_INST,func_detach), NULL, "detach"},
 107         { "func_xlat", PW_TYPE_STRING_PTR,
 108           offsetof(PERL_INST,func_xlat), NULL, "xlat"},
 109
 110         { NULL, -1, 0, NULL, NULL }             /* end the list */
 111 };
 112
 113 /*
 114  * man perlembed
 115  */
 116 EXTERN_C void boot_DynaLoader(pTHX_ CV* cv);
 117
 118 /*
 119  *      We share one perl interpreter among all of the instances
 120  *      of this module.
 121  */
 122 static PerlInterpreter  *my_perl;
 123
 124
 125 /*
 126  *      Do any per-module initialization.  e.g. set up connections
 127  *      to external databases, read configuration files, set up
 128  *      dictionary entries, etc.
 129  *
 130  *      Try to avoid putting too much stuff in here - it's better to
 131  *      do it in instantiate() where it is not global.
 132  */
 133 static int perl_init(void)
 134 {
 135         if ((my_perl = perl_alloc()) == NULL) {
 136                 radlog(L_INFO, "rlm_perl: No memory for allocating new perl !");
 137                 return -1;
 138         }
 139
 140         perl_construct(my_perl);
 141
 142         return 0;
 143
 144 }
 145
 146
 147 /*
 148  * man perlembed
 149  */
 150 static void xs_init(pTHX)
 151 {
 152         const char *file = __FILE__;
 153         dXSUB_SYS;
 154
 155         /* DynaLoader is a special case */
 156         newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
 157
 158 }
 159 /*
 160  *
 161  * This is wrapper for radlog
 162  * Now users can call radiusd::radlog(level,msg) wich is the same
 163  * calling radlog from C code.
 164  * Boyan
 165  */
 166 static XS(XS_radiusd_radlog)
 167 {
 168        dXSARGS;
 169        int     level;
 170        char    *msg;
 171
 172        level = *(int *) SvIV(ST(0));
 173        msg   = (char *) SvPV(ST(1), PL_na);
 174
 175        /*
 176         *       Because 'msg' is a 'char *', we don't want '%s', etc.
 177         *       in it to give us printf-style vulnerabilities.
 178         */
 179        radlog(level, "rlm_perl: %s", msg);
 180
 181        XSRETURN_NO;
 182 }
 183
 184 /*
 185  * The xlat function
 186  */
 187 static int perl_xlat(void *instance, REQUEST *request, char *fmt, char * out,
 188                      int freespace, RADIUS_ESCAPE_STRING func)
 189 {
 190         PERL_INST       *inst= (PERL_INST *) instance;
 191         char            params[1024], *tmp_ptr, *ptr, *tmp;
 192         int             count, ret;
 193         STRLEN          n_a;
 194
 195         dSP;
 196         ENTER;
 197         SAVETMPS;
 198
 199         /*
 200          * Do an xlat on the provided string (nice recursive operation).
 201         */
 202         if (!radius_xlat(params, sizeof(params), fmt, request, func)) {
 203                 radlog(L_ERR, "rlm_perl: xlat failed.");
 204                 return 0;
 205         }
 206
 207         PERL_SET_CONTEXT(my_perl);
 208         ptr = strtok(params, " ");
 209
 210         PUSHMARK(SP);
 211         XPUSHs(sv_2mortal(newSVpv(ptr,0)));
 212
 213         while ((tmp_ptr = strtok(NULL, " ")) != NULL) {
 214                 XPUSHs(sv_2mortal(newSVpv(tmp_ptr,0)));
 215         }
 216
 217         PUTBACK;
 218         PERL_SET_CONTEXT(my_perl);
 219
 220         count = call_pv(inst->func_xlat, G_SCALAR | G_EVAL);
 221
 222         SPAGAIN;
 223
 224         if (SvTRUE(ERRSV)) {
 225                 radlog(L_ERR, "rlm_perl: perl_xlat exit %s\n",
 226                        SvPV(ERRSV,n_a));
 227                 return 0;
 228         }
 229
 230         if (count > 0) {
 231                 tmp = POPp;
 232                 ret = strlen(tmp);
 233                 strncpy(out,tmp,ret);
 234
 235                 radlog(L_DBG,"rlm_perl: Len is %d , out is %s freespace is %d",
 236                        ret, out,freespace);
 237
 238                 PUTBACK ;
 239                 FREETMPS ;
 240                 LEAVE ;
 241
 242                 if (ret <= freespace)
 243                         return ret;
 244         }
 245         return 0;
 246 }
 247
 248 /*
 249  *      Do any per-module initialization that is separate to each
 250  *      configured instance of the module.  e.g. set up connections
 251  *      to external databases, read configuration files, set up
 252  *      dictionary entries, etc.
 253  *
 254  *      If configuration information is given in the config section
 255  *      that must be referenced in later calls, store a handle to it
 256  *      in *instance otherwise put a null pointer there.
 257  *
 258  *      Boyan:
 259  *      Setup a hashes wich we will use later
 260  *      parse a module and give him a chance to live
 261  *
 262  */
 263 static int perl_instantiate(CONF_SECTION *conf, void **instance)
 264 {
 265         PERL_INST       *inst = (PERL_INST *) instance;
 266         char *embed[2], *xlat_name;
 267         int exitstatus = 0;
 268
 269         /*
 270          *      Set up a storage area for instance data
 271          */
 272         inst = rad_malloc(sizeof(PERL_INST));
 273         memset(inst, 0, sizeof(PERL_INST));
 274
 275         /*
 276          *      If the configuration parameters can't be parsed, then
 277          *      fail.
 278          */
 279         if (cf_section_parse(conf, inst, module_config) < 0) {
 280                 free(inst);
 281                 return -1;
 282         }
 283
 284         PERL_SET_CONTEXT(my_perl);
 285
 286         embed[0] = NULL;
 287         embed[1] = inst->module;
 288
 289         exitstatus = perl_parse(my_perl, xs_init, 2, embed, NULL);
 290
 291         PERL_SET_CONTEXT(my_perl);
 292         if(!exitstatus) {
 293                 exitstatus = perl_run(my_perl);
 294         } else {
 295                 radlog(L_INFO,"rlm_perl: perl_parse failed: %s not found or has syntax errors. \n", inst->module);
 296                 return (-1);
 297         }
 298
 299         newXS("radiusd::radlog",XS_radiusd_radlog, "rlm_perl.c");
 300
 301         inst->rad_reply_hv = get_hv("RAD_REPLY",1);
 302         inst->rad_check_hv = get_hv("RAD_CHECK",1);
 303         inst->rad_request_hv = get_hv("RAD_REQUEST",1);
 304
 305         xlat_name = cf_section_name2(conf);
 306         if (xlat_name == NULL)
 307                 xlat_name = cf_section_name1(conf);
 308         if (xlat_name){
 309                 inst->xlat_name = strdup(xlat_name);
 310                 xlat_register(xlat_name, perl_xlat, inst);
 311         }
 312         *instance = inst;
 313
 314         return 0;
 315 }
 316
 317 /*
 318  *      Boyan get the vps and put them in perl hash
 319  */
 320 static void perl_store_vps(VALUE_PAIR *vp, HV *rad_hv)
 321 {
 322         char            buffer[256];
 323
 324         hv_clear(rad_hv);
 325
 326         for ( ; vp != NULL; vp = vp->next) {
 327                 int len;
 328
 329                 len = vp_prints_value(buffer, sizeof(buffer), vp, FALSE);
 330
 331                 hv_store(rad_hv, vp->name, strlen(vp->name),
 332                          newSVpv(buffer, len),0);
 333         }
 334 }
 335 /*
 336  *      Boyan :
 337  *      Gets the content from hashes
 338  *
 339  */
 340 static int get_hv_content(HV *my_hv, VALUE_PAIR **vp)
 341 {
 342         SV              *res_sv;
 343         char            *key, *val;
 344         I32             key_len,i;
 345         int             val_len;
 346         VALUE_PAIR      *vpp;
 347
 348         for (i = hv_iterinit(my_hv); i > 0; i--) {
 349                 res_sv = hv_iternextsv(my_hv,&key,&key_len);
 350                 val = SvPV(res_sv,val_len);
 351                 vpp = pairmake(key, val, T_OP_EQ);
 352                 if (vpp != NULL) {
 353                         pairadd(vp, vpp);
 354                 } else {
 355                         radlog(L_DBG,"rlm_perl: ERROR: Failed to create pair %s = %s",
 356                                key, val);
 357                 }
 358         }
 359
 360         return 1;
 361 }
 362
 363 /*
 364  *      Call the function_name inside the module
 365  *      Store all vps in hashes %RAD_CHECK %RAD_REPLY %RAD_REQUEST
 366  *
 367  */
 368 static int rlmperl_call(void *instance, REQUEST *request, char *function_name)
 369 {
 370         PERL_INST       *inst = instance;
 371         VALUE_PAIR      *vp;
 372         int             exitstatus, count;
 373         STRLEN          n_a;
 374
 375         dSP;
 376
 377         /*
 378          *      Radius has told us to call this function, but none
 379          *      is defined.
 380          */
 381         if (!function_name) {
 382                 return RLM_MODULE_FAIL;
 383         }
 384
 385         ENTER;
 386         SAVETMPS;
 387
 388         perl_store_vps(request->reply->vps, inst->rad_reply_hv);
 389         perl_store_vps(request->config_items, inst->rad_check_hv);
 390         perl_store_vps(request->packet->vps, inst->rad_request_hv);
 391
 392         vp = NULL;
 393
 394         PERL_SET_CONTEXT(my_perl);
 395
 396         PUSHMARK(SP);
 397         count = call_pv(function_name, G_SCALAR | G_EVAL);
 398
 399         SPAGAIN;
 400
 401         if (count != 1) {
 402                 exitstatus = RLM_MODULE_REJECT;
 403         } else {
 404                 exitstatus = POPi;
 405         }
 406
 407         PUTBACK;
 408
 409         if (SvTRUE(ERRSV)) {
 410                 exitstatus = SvIV(perl_get_sv("!",FALSE));
 411                 radlog(L_DBG, "rlm_perl: perl_embed:: module = %s , func = %s exit status=%d, %s\n",
 412                        inst->module,
 413                        function_name,exitstatus, SvPV(ERRSV,n_a));
 414         }
 415
 416
 417         PERL_SET_CONTEXT(my_perl);
 418         if ((get_hv_content(inst->rad_reply_hv, &vp)) == 1) {
 419                 pairmove(&request->reply->vps, &vp);
 420                 pairfree(&vp);
 421         }
 422
 423         PERL_SET_CONTEXT(my_perl);
 424         if ((get_hv_content(inst->rad_check_hv, &vp)) == 1 ) {
 425                 pairmove(&request->config_items, &vp);
 426                 pairfree(&vp);
 427         }
 428
 429         return exitstatus;
 430 }
 431
 432 /*
 433  *      Find the named user in this modules database.  Create the set
 434  *      of attribute-value pairs to check and reply with for this user
 435  *      from the database. The authentication code only needs to check
 436  *      the password, the rest is done here.
 437  */
 438 static int perl_authorize(void *instance, REQUEST *request)
 439 {
 440         return rlmperl_call(instance, request,
 441                             ((PERL_INST *)instance)->func_authorize);
 442 }
 443
 444 /*
 445  *      Authenticate the user with the given password.
 446  */
 447 static int perl_authenticate(void *instance, REQUEST *request)
 448 {
 449         return rlmperl_call(instance, request,
 450                             ((PERL_INST *)instance)->func_authenticate);
 451 }
 452
 453
 454 /*
 455  *      Massage the request before recording it or proxying it
 456  */
 457 static int perl_preacct(void *instance, REQUEST *request)
 458 {
 459         return rlmperl_call(instance, request,
 460                             ((PERL_INST *)instance)->func_preacct);
 461 }
 462
 463 /*
 464  *      Write accounting information to this modules database.
 465  */
 466
 467 static int perl_accounting(void *instance, REQUEST *request)
 468 {
 469         return rlmperl_call(instance, request,
 470                             ((PERL_INST *)instance)->func_accounting);
 471 }
 472 /*
 473  *      Check for simultaneouse-use
 474  */
 475
 476 static int perl_checksimul(void *instance, REQUEST *request)
 477 {
 478         return rlmperl_call(instance, request,
 479                             ((PERL_INST *)instance)->func_checksimul);
 480 }
 481
 482 /*
 483  * Detach a instance give a chance to a module to make some internal setup ...
 484  */
 485 static int perl_detach(void *instance)
 486 {
 487         PERL_INST       *inst = (PERL_INST *) instance;
 488         int             status,count=0;
 489
 490         dSP;
 491         radlog(L_DBG,"Enter the detach function");
 492
 493
 494         PERL_SET_CONTEXT(my_perl);
 495
 496         PUSHMARK(SP);
 497         count = call_pv(inst->func_detach, G_SCALAR | G_EVAL);
 498
 499         SPAGAIN;
 500
 501         if (count != 1) {
 502                 status = RLM_MODULE_REJECT;
 503         } else {
 504                 status = POPi;
 505         }
 506
 507         PUTBACK;
 508
 509         xlat_unregister(inst->xlat_name, perl_xlat);
 510         free(inst->xlat_name);
 511
 512         if (inst->func_authorize) free(inst->func_authorize);
 513         if (inst->func_authenticate) free(inst->func_authenticate);
 514         if (inst->func_accounting) free(inst->func_accounting);
 515         if (inst->func_preacct) free(inst->func_preacct);
 516         if (inst->func_checksimul) free(inst->func_checksimul);
 517         if (inst->func_detach) free(inst->func_detach);
 518
 519         free(inst);
 520         return status;
 521 }
 522
 523 /*
 524  *      The module name should be the only globally exported symbol.
 525  *      That is, everything else should be 'static'.
 526  *
 527  *      If the module needs to temporarily modify it's instantiation
 528  *      data, the type should be changed to RLM_TYPE_THREAD_UNSAFE.
 529  *      The server will then take care of ensuring that the module
 530  *      is single-threaded.
 531  */
 532 module_t rlm_perl = {
 533         "perl",                         /* Name */
 534         RLM_TYPE_THREAD_UNSAFE,         /* type */
 535         perl_init,                      /* initialization */
 536         perl_instantiate,               /* instantiation */
 537         {
 538                 perl_authenticate,
 539                 perl_authorize,
 540                 perl_preacct,
 541                 perl_accounting,
 542                 NULL,                   /* check simul */
 543                 NULL,                   /* pre-proxy */
 544                 NULL,                   /* post-proxy */
 545                 NULL                    /* post-auth */
 546         },
 547         perl_detach,                    /* detach */
 548         NULL,                           /* destroy */
 549 };