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