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