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 #include <EXTERN.h>
  40 #include <perl.h>
  41 #include <XSUB.h>
  42
  43 #ifndef DO_CLEAN
  44 #define DO_CLEAN 0
  45 #endif
  46
  47 static const char rcsid[] = "$Id$";
  48
  49 /*
  50  *      Define a structure for our module configuration.
  51  *
  52  *      These variables do not need to be in a structure, but it's
  53  *      a lot cleaner to do so, and a pointer to the structure can
  54  *      be used as the instance handle.
  55  */
  56 typedef struct perl_inst {
  57         char    *cmd;
  58         char    *persistent;
  59         char    *xlat_name;
  60
  61         PerlInterpreter         *perl;
  62         HV                      *env_hv;
  63         HV                      *result_hv;
  64 } PERL_INST;
  65
  66 /*
  67  *      A mapping of configuration file names to internal variables.
  68  *
  69  *      Note that the string is dynamically allocated, so it MUST
  70  *      be freed.  When the configuration file parse re-reads the string,
  71  *      it free's the old one, and strdup's the new one, placing the pointer
  72  *      to the strdup'd string into 'config.string'.  This gets around
  73  *      buffer over-flows.
  74  */
  75 static CONF_PARSER module_config[] = {
  76   { "cmd",  PW_TYPE_STRING_PTR, offsetof(PERL_INST,cmd), NULL,  NULL},
  77   { "persistent", PW_TYPE_STRING_PTR, offsetof(PERL_INST,persistent), NULL, NULL},
  78   { NULL, -1, 0, NULL, NULL }           /* end the list */
  79 };
  80
  81 /*
  82  * man perlembed
  83  */
  84 EXTERN_C void boot_DynaLoader(pTHX_ CV* cv);
  85
  86 /*
  87  *      Do any per-module initialization.  e.g. set up connections
  88  *      to external databases, read configuration files, set up
  89  *      dictionary entries, etc.
  90  *
  91  *      Try to avoid putting too much stuff in here - it's better to
  92  *      do it in instantiate() where it is not global.
  93  */
  94 static int perl_init(void)
  95 {
  96         /*
  97          *      Everything's OK, return without an error.
  98          */
  99         return 0;
 100 }
 101
 102
 103 /*
 104  * man perlembed
 105  */
 106 static void xs_init(pTHX)
 107 {
 108         const char *file = __FILE__;
 109         dXSUB_SYS;
 110
 111         /* DynaLoader is a special case */
 112         DEBUG("rlm_perl:: xs_init enter \n");
 113         newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
 114         DEBUG("rlm_perl:: xs_init leave \n");
 115
 116 }
 117
 118 /*
 119  * Perl xlat we use already running perl just recompile and store in memory
 120  * REMEMBER: each file will only be compiled once. Note that the process
 121  * will continue to grow for each file that it uses and is not compiled.
 122  *
 123  *  e.g.
 124  *  %{perl:/usr/bin/test.pl %{User-Name}} will run /usr/bin/test.pl,
 125  * give @ARGV with User-Name in $ARGV[0]
 126  *  To return something just assign it to $main::ret_val
 127  *
 128  * test.pl:
 129  *
 130  * use strict;
 131  * $!=0;
 132  * my ($ret_val);
 133  * print "ARGV[1]=$ARGV[1] ARGV[2]=$ARGV[2]\n";
 134  * $main::ret_val = "B";
 135  * die;
 136  */
 137
 138 static int perl_xlat(void *instance, REQUEST *request, char *fmt, char *out, int freespace,
 139                                         RADIUS_ESCAPE_STRING func)
 140 {
 141         PERL_INST       *inst=instance;
 142         AV      *array_av;
 143         SV      *ret_val;
 144         char    *args[] = {"", DO_CLEAN, NULL};
 145         char    params[1024], *tmp_ptr, *ptr;
 146         int     exitstatus=0,len;
 147         I32     key;
 148         STRLEN  n_a;
 149
 150         /*
 151          * Do an xlat on the provided string (nice recursive operation).
 152         */
 153
 154         if (!radius_xlat(params, sizeof(params), fmt, request, func))
 155         {
 156                 radlog(L_ERR, "rlm_perl: xlat failed.");
 157                 return 0;
 158         }
 159
 160         PERL_SET_CONTEXT(inst->perl);
 161         ptr = strtok(params, " ");
 162
 163         args[0] = ptr;
 164         array_av = get_av("ARGV",0);
 165
 166         ret_val = get_sv("main::ret_val",1);
 167
 168         key = 0;
 169         while ((tmp_ptr=strtok(NULL, " ")) != NULL) {
 170                 av_store(array_av,key++,newSVpv(tmp_ptr,0));
 171         }
 172
 173         PERL_SET_CONTEXT(inst->perl);
 174         call_argv("Embed::Persistent::eval_file", G_DISCARD | G_EVAL, args);
 175
 176         if (SvTRUE(ERRSV)) {
 177                 exitstatus = SvIV(perl_get_sv("!",FALSE));
 178                 radlog(L_INFO, "perl_embed::perl_xlat exit status=%d, %s\n", exitstatus, SvPV(ERRSV,n_a));
 179         }
 180
 181         /*
 182          * Now get the variable we need
 183          * His name is $ret_val
 184          */
 185
 186         out = NULL;
 187
 188         if (SvTRUE(ret_val)) {
 189
 190                 out =  SvPV(ret_val,n_a);
 191                 len = strlen(out);
 192
 193                 radlog(L_INFO,"Len is %d , out is %s", len, out);
 194
 195                 if (len <= freespace)
 196                         return len;
 197         }
 198
 199         return 0;
 200
 201 }
 202
 203 /*
 204  *      Do any per-module initialization that is separate to each
 205  *      configured instance of the module.  e.g. set up connections
 206  *      to external databases, read configuration files, set up
 207  *      dictionary entries, etc.
 208  *
 209  *      If configuration information is given in the config section
 210  *      that must be referenced in later calls, store a handle to it
 211  *      in *instance otherwise put a null pointer there.
 212  */
 213 static int perl_instantiate(CONF_SECTION *conf, void **instance)
 214 {
 215         PERL_INST       *inst;
 216         char *embed[2], *xlat_name;
 217         int exitstatus = 0;
 218
 219         /*
 220          *      Set up a storage area for instance data
 221          */
 222
 223         inst = rad_malloc(sizeof(PERL_INST));
 224         memset(inst, 0, sizeof(PERL_INST));
 225
 226         /*
 227          *      If the configuration parameters can't be parsed, then
 228          *      fail.
 229          */
 230         if (cf_section_parse(conf, inst, module_config) < 0) {
 231                 free(inst);
 232                 return -1;
 233         }
 234
 235
 236         /*
 237          * Boyan
 238          * Prepare perl instance
 239          *
 240          */
 241         if((inst->perl = perl_alloc()) == NULL) {
 242                 radlog(L_INFO, "no memory!");
 243                 return -1;
 244         }
 245
 246         PERL_SET_CONTEXT(inst->perl);
 247         perl_construct(inst->perl);
 248
 249         PERL_SET_CONTEXT(inst->perl);
 250
 251         embed[0] = NULL;
 252         embed[1] = inst->persistent;
 253
 254         exitstatus = perl_parse(inst->perl, xs_init, 2, embed, NULL);
 255
 256         PERL_SET_CONTEXT(inst->perl);
 257         if(!exitstatus) {
 258                 exitstatus = perl_run(inst->perl);
 259         } else {
 260                 radlog(L_INFO,"perl_parse failed: %s not found or has syntax errors. \n", inst->persistent);
 261                 return (-1);
 262         }
 263
 264         inst->env_hv = perl_get_hv("ENV",0);
 265         inst->result_hv = perl_get_hv("main::result",1);
 266
 267         xlat_name = cf_section_name2(conf);
 268         if (xlat_name == NULL)
 269                 xlat_name = cf_section_name1(conf);
 270         if (xlat_name){
 271                 inst->xlat_name = strdup(xlat_name);
 272                 xlat_register(xlat_name, perl_xlat, inst);
 273         }
 274         *instance = inst;
 275
 276         return 0;
 277 }
 278
 279 /*
 280  *  Boyan get the request and put them in perl hash
 281  *  which will be given to perl cmd
 282  */
 283 static void perl_env(VALUE_PAIR *vp, PERL_INST *inst)
 284 {
 285         char            buffer[256];
 286
 287         hv_clear(inst->env_hv);
 288         hv_clear(inst->result_hv);
 289
 290         for ( ; vp != NULL; vp = vp->next) {
 291                 int len;
 292
 293                 len = vp_prints_value(buffer, sizeof(buffer), vp, FALSE);
 294
 295                 hv_store(inst->env_hv, vp->name, strlen(vp->name),
 296                          newSVpv(buffer, len),0);
 297         }
 298 }
 299
 300 /*
 301  * return structs and status 0 OK 1 Not
 302  * Boyan
 303  */
 304 static int rlmperl_call(void *instance, REQUEST *request)
 305 {
 306
 307         PERL_INST       *inst = (PERL_INST *) instance;
 308         SV              *res_sv;
 309         VALUE_PAIR      *vp;
 310         char            *key, *val, *ptr, *p;
 311         char            *args[] = {NULL, DO_CLEAN, NULL};
 312         char            answer[4096];
 313         I32             key_len,i;
 314         int             val_len;
 315         int             exitstatus = 0, comma = 0;
 316         STRLEN n_a;
 317
 318         args[0] = inst->cmd;
 319
 320         perl_env(request->packet->vps, inst);
 321
 322         for (i = hv_iterinit(inst->env_hv); i > 0; i--) {
 323                 res_sv = hv_iternextsv(inst->env_hv, &key, &key_len);
 324                 val = SvPV(res_sv,val_len);
 325                 radlog(L_DBG, "ENV %s= %s", key, val);
 326         }
 327
 328         PERL_SET_CONTEXT(inst->perl);
 329         call_argv("Embed::Persistent::eval_file", G_DISCARD | G_EVAL, args);
 330
 331         exitstatus = 0;
 332
 333         if (SvTRUE(ERRSV)) {
 334                 exitstatus = SvIV(perl_get_sv("!",FALSE));;
 335                 radlog(L_INFO, "exit status=%d, %s\n", exitstatus,
 336                        SvPV(ERRSV,n_a));
 337         }
 338
 339         ptr = answer;
 340         PERL_SET_CONTEXT(inst->perl);
 341
 342         for (i = hv_iterinit(inst->result_hv); i > 0; i--) {
 343                 res_sv = hv_iternextsv(inst->result_hv,&key,&key_len);
 344                 val = SvPV(res_sv,val_len);
 345                 sprintf(ptr, "%s=\"%s\"\n", key, val); /* FIXME: snprintf */
 346                 ptr += key_len + val_len + 4;
 347         }
 348         /* perl_free(inst->perl); */
 349
 350         *ptr='\0';
 351         vp = NULL;
 352
 353         for (p = answer; *p; p++) {
 354                 if (*p == '\n') {
 355                         *p = comma ? ' ' : ',';
 356                         p++; comma = 0;
 357                 }
 358                 if (*p == ',') comma++;
 359         }
 360
 361         /*
 362          * Replace any trailing comma by a NUL.
 363          */
 364         if (answer[strlen(answer) - 1] == ',') {
 365                 answer[strlen(answer) - 1] = '\0';
 366         }
 367         radlog(L_INFO,"perl_embed :: value-pairs: %s", answer);
 368
 369         if (userparse(answer, &vp) < 0) {
 370                 radlog(L_ERR, "perl_embed :: %s: unparsable reply", args[0]);
 371         } else {
 372                 pairmove(&request->reply->vps, &vp);
 373                 pairfree(&vp);
 374         }
 375         return exitstatus;
 376
 377 }
 378
 379 /*
 380  *      Find the named user in this modules database.  Create the set
 381  *      of attribute-value pairs to check and reply with for this user
 382  *      from the database. The authentication code only needs to check
 383  *      the password, the rest is done here.
 384  */
 385 static int perl_authorize(void *instance, REQUEST *request)
 386 {
 387         int status = 0;
 388
 389         radlog(L_INFO,"perl_embed :: Enter Authorize");
 390
 391         if ((status = rlmperl_call(instance, request)) == 0) {
 392                 return RLM_MODULE_OK;
 393         }
 394
 395         return RLM_MODULE_FAIL;
 396 }
 397
 398 /*
 399  *      Authenticate the user with the given password.
 400  */
 401 static int perl_authenticate(void *instance, REQUEST *request)
 402 {
 403         int status = 0;
 404
 405         radlog(L_INFO,"perl_embed :: Enter Auth");
 406
 407         if ((status = rlmperl_call(instance, request)) == 0) {
 408                 return RLM_MODULE_OK;
 409         }
 410
 411         return RLM_MODULE_FAIL;
 412 }
 413
 414
 415 /*
 416  *      Massage the request before recording it or proxying it
 417  */
 418 static int perl_preacct(void *instance, REQUEST *request)
 419 {
 420         int status = 0;
 421
 422         radlog(L_INFO,"mod_perl ::  Enter PreAccounting");
 423
 424         if ((status = rlmperl_call(instance, request)) == 0) {
 425                 return RLM_MODULE_OK;
 426         }
 427
 428         return RLM_MODULE_FAIL;
 429 }
 430
 431 /*
 432  *      Write accounting information to this modules database.
 433  */
 434
 435 static int perl_accounting(void *instance, REQUEST *request)
 436 {
 437         int status = 0;
 438
 439         radlog(L_INFO,"mod_perl ::  Enter Accounting");
 440
 441         if ((status = (rlmperl_call(instance, request))) == 0) {
 442                 return RLM_MODULE_OK;
 443         }
 444
 445         return RLM_MODULE_FAIL;
 446 }
 447
 448 /*
 449  * Detach a instance free all ..
 450  */
 451 static int perl_detach(void *instance)
 452 {
 453         PERL_INST *inst=instance;
 454
 455         PERL_SET_CONTEXT(inst->perl);
 456         perl_destruct(inst->perl);
 457         PERL_SET_CONTEXT(inst->perl);
 458         perl_free(inst->perl);
 459
 460         hv_clear(inst->env_hv);
 461         hv_clear(inst->result_hv);
 462
 463         xlat_unregister(inst->xlat_name, perl_xlat);
 464         free(inst->xlat_name);
 465
 466         free(inst->cmd);
 467         free(inst->persistent);
 468
 469         free(inst);
 470         return 0;
 471 }
 472
 473 /*
 474  *      The module name should be the only globally exported symbol.
 475  *      That is, everything else should be 'static'.
 476  *
 477  *      If the module needs to temporarily modify it's instantiation
 478  *      data, the type should be changed to RLM_TYPE_THREAD_UNSAFE.
 479  *      The server will then take care of ensuring that the module
 480  *      is single-threaded.
 481  */
 482 module_t rlm_perl = {
 483         "perl",                         /* Name */
 484         RLM_TYPE_THREAD_UNSAFE,         /* type */
 485         perl_init,                      /* initialization */
 486         perl_instantiate,               /* instantiation */
 487         {
 488                 perl_authenticate,
 489                 perl_authorize,
 490                 perl_preacct,
 491                 perl_accounting
 492         },
 493         perl_detach,                    /* detach */
 494         NULL,                           /* destroy */
 495 };