nnrpd/perl.c

   1 /*  $Id: perl.c 7815 2008-05-05 08:43:58Z iulius $
   2 **
   3 **  Embedded Perl support for INN.
   4 **
   5 **  Originally written by Christophe Wolfhugel <wolf@pasteur.fr> (although
   6 **  he wouldn't recongize it any more, so don't blame him) and modified,
   7 **  expanded, and tweaked by James Brister, Dave Hayes, Andrew Gierth, and
   8 **  Russ Allbery among others.
   9 **
  10 **  This file should contain all innd-specific Perl linkage.  Linkage
  11 **  applicable to both innd and nnrpd should go into lib/perl.c instead.
  12 **
  13 **  We are assuming Perl 5.004 or later.
  14 */
  15
  16 #include "config.h"
  17 #include "clibrary.h"
  18
  19 #include "inn/innconf.h"
  20 #include "nnrpd.h"
  21 #include "paths.h"
  22 #include "post.h"
  23
  24 #include "nntp.h"
  25
  26 /* Skip this entire file if DO_PERL (./configure --with-perl) isn't set. */
  27 #ifdef DO_PERL
  28
  29 #include <EXTERN.h>
  30 #include <perl.h>
  31 #include <XSUB.h>
  32 #include "ppport.h"
  33
  34 #include "innperl.h"
  35
  36 extern HEADER   Table[], *EndOfTable;
  37 extern char LogName[];
  38 extern char PERMuser[];
  39
  40 extern char **OtherHeaders;
  41 extern int OtherCount;
  42 extern bool HeadersModified;
  43
  44 extern bool PerlLoaded;
  45
  46 /* #define DEBUG_MODIFY only if you want to see verbose outout */
  47 #ifdef DEBUG_MODIFY
  48 static FILE *flog;
  49 void dumpTable(char *msg);
  50 #endif /* DEBUG_MODIFY */
  51
  52 char *HandleHeaders(char *article)
  53 {
  54    dSP;
  55    HEADER       *hp;
  56    HV           *hdr;
  57    SV           *body;
  58    int          rc;
  59    char         *p, *q;
  60    static char  buf[256];
  61    int   i;
  62    char *s,*t;
  63    HE            *scan;
  64    SV            *modswitch;
  65    int            OtherSize;
  66    char *argv[] = { NULL };
  67
  68    if(!PerlLoaded) {
  69        loadPerl();
  70    }
  71
  72    if (!PerlFilterActive)
  73        return NULL; /* not really necessary */
  74
  75 #ifdef DEBUG_MODIFY
  76    if ((flog = fopen("/var/news/log/nnrpdperlerrror","a+")) == NULL) {
  77      syslog(L_ERROR,"Whoops. Can't open error log: %m");
  78    }
  79 #endif /* DEBUG_MODIFY */
  80
  81    ENTER ;
  82    SAVETMPS ;
  83
  84    /* Create the Perl Hash */
  85    hdr = perl_get_hv("hdr", true);
  86    for (hp = Table; hp < EndOfTable; hp++) {
  87       if (hp->Body)
  88          hv_store(hdr, (char *) hp->Name, strlen(hp->Name), newSVpv(hp->Body, 0), 0);
  89    }
  90
  91    /* Also store other headers */
  92    OtherSize = OtherCount;
  93    for (i = 0; i < OtherCount; i++) {
  94         p = OtherHeaders[i];
  95         if (p == NULL) {
  96           syslog (L_ERROR,"Null header number %d copying headers for Perl",i);
  97           continue;
  98         }
  99         s = strchr(p,':');
 100         if (s == NULL) {
 101           syslog (L_ERROR,"Bad header copying headers for Perl: '%s'",p);
 102           continue;
 103         }
 104         s++;
 105         t = (*s == ' ' ? s + 1 : s);
 106         hv_store(hdr, p, (s - p) - 1, newSVpv(t, 0), 0);
 107    }
 108    /* Store user */
 109    sv_setpv(perl_get_sv("user",true), PERMuser);
 110
 111    /* Store body */
 112    body = perl_get_sv("body", true);
 113    sv_setpv(body, article);
 114
 115    /* Call the filtering function */
 116    rc = perl_call_argv("filter_post", G_EVAL|G_SCALAR, argv);
 117
 118    SPAGAIN;
 119
 120    /* Restore headers */
 121    modswitch = perl_get_sv("modify_headers",false);
 122    HeadersModified = false;
 123    if (SvTRUE(modswitch)) {
 124      HeadersModified = true;
 125      i = 0;
 126
 127 #ifdef DEBUG_MODIFY
 128      dumpTable("Before mod");
 129 #endif /* DEBUG_MODIFY */
 130
 131      hv_iterinit(hdr);
 132      while ((scan = hv_iternext(hdr)) != NULL) {
 133        /* Get the values */
 134        p = HePV(scan, PL_na);
 135        s = SvPV(HeVAL(scan), PL_na);
 136 #ifdef DEBUG_MODIFY
 137        fprintf(flog,"Hash iter: '%s','%s'\n",p,s);
 138 #endif /* DEBUG_MODIFY */
 139
 140        /* See if it's a table header */
 141        for (hp = Table; hp < EndOfTable; hp++) {
 142          if (strncasecmp(p, hp->Name, hp->Size) == 0) {
 143            char *copy = xstrdup(s);
 144            HDR_SET(hp - Table, copy);
 145            hp->Len = TrimSpaces(hp->Value);
 146            for (q = hp->Value ; ISWHITE(*q) || *q == '\n' ; q++)
 147              continue;
 148            hp->Body = q;
 149            if (hp->Len == 0) {
 150              free(hp->Value);
 151              hp->Value = hp->Body = NULL;
 152            }
 153            break;
 154          }
 155        }
 156        if (hp != EndOfTable) continue;
 157
 158        /* Add to other headers */
 159        if (i >= OtherSize - 1) {
 160          OtherSize += 20;
 161          OtherHeaders = xrealloc(OtherHeaders, OtherSize * sizeof(char *));
 162        }
 163        t = concat(p, ": ", s, (char *) 0);
 164        OtherHeaders[i++] = t;
 165      }
 166      OtherCount = i;
 167 #ifdef DEBUG_MODIFY
 168      dumpTable("After Mod");
 169 #endif /* DEBUG_MODIFY */
 170    }
 171
 172    hv_undef (hdr);
 173    sv_setsv (body, &PL_sv_undef);
 174
 175    buf [0] = '\0' ;
 176
 177    if (SvTRUE(ERRSV))     /* check $@ */ {
 178        syslog (L_ERROR,"Perl function filter_post died: %s",
 179                SvPV(ERRSV, PL_na)) ;
 180        (void)POPs ;
 181        PerlFilter (false) ;
 182    } else if (rc == 1) {
 183        p = POPp;
 184        if (p != NULL && *p != '\0')
 185            strlcpy(buf, p, sizeof(buf));
 186    }
 187
 188    FREETMPS ;
 189    LEAVE ;
 190
 191    if (buf[0] != '\0')
 192       return buf ;
 193    return NULL;
 194 }
 195
 196 void loadPerl(void) {
 197     char *path;
 198
 199     path = concatpath(innconf->pathfilter, _PATH_PERL_FILTER_NNRPD);
 200     PERLsetup(NULL, path, "filter_post");
 201     free(path);
 202     PerlFilter(true);
 203     PerlLoaded = true;
 204 }
 205
 206 void perlAccess(char *user, struct vector *access_vec) {
 207   dSP;
 208   HV              *attribs;
 209   SV              *sv;
 210   int             rc, i;
 211   char            *key, *val, *buffer;
 212
 213   if (!PerlFilterActive)
 214     return;
 215
 216   ENTER;
 217   SAVETMPS;
 218
 219   attribs = perl_get_hv("attributes", true);
 220   hv_store(attribs, "hostname", 8, newSVpv(ClientHost, 0), 0);
 221   hv_store(attribs, "ipaddress", 9, newSVpv(ClientIpString, 0), 0);
 222   hv_store(attribs, "port", 4, newSViv(ClientPort), 0);
 223   hv_store(attribs, "interface", 9, newSVpv(ServerHost, 0), 0);
 224   hv_store(attribs, "intipaddr", 9, newSVpv(ServerIpString, 0), 0);
 225   hv_store(attribs, "intport", 7, newSViv(ServerPort), 0);
 226   hv_store(attribs, "username", 8, newSVpv(user, 0), 0);
 227
 228   PUSHMARK(SP);
 229
 230   if (perl_get_cv("access", 0) == NULL) {
 231     syslog(L_ERROR, "Perl function access not defined");
 232     Reply("%d Internal Error (3).  Goodbye\r\n", NNTP_ACCESS_VAL);
 233     ExitWithStats(1, true);
 234   }
 235
 236   rc = perl_call_pv("access", G_EVAL|G_ARRAY);
 237
 238   SPAGAIN;
 239
 240   if (rc == 0 ) { /* Error occured, same as checking $@ */
 241     syslog(L_ERROR, "Perl function access died: %s",
 242            SvPV(ERRSV, PL_na));
 243     Reply("%d Internal Error (1).  Goodbye\r\n", NNTP_ACCESS_VAL);
 244     ExitWithStats(1, true);
 245   }
 246
 247   if ((rc % 2) != 0) {
 248     syslog(L_ERROR, "Perl function access returned an odd number of arguments: %i", rc);
 249     Reply("%d Internal Error (2).  Goodbye\r\n", NNTP_ACCESS_VAL);
 250     ExitWithStats(1, true);
 251   }
 252
 253   vector_resize(access_vec, (rc / 2));
 254
 255   buffer = xmalloc(BIG_BUFFER);
 256
 257   for (i = (rc / 2); i >= 1; i--) {
 258     sv = POPs;
 259     val = SvPV(sv, PL_na);
 260     sv = POPs;
 261     key = SvPV(sv, PL_na);
 262
 263     strlcpy(buffer, key, BIG_BUFFER);
 264     strlcat(buffer, ": \"", BIG_BUFFER);
 265     strlcat(buffer, val, BIG_BUFFER);
 266     strlcat(buffer, "\"\n", BIG_BUFFER);
 267
 268     vector_add(access_vec, xstrdup(buffer));
 269   }
 270
 271   free(buffer);
 272
 273   PUTBACK;
 274   FREETMPS;
 275   LEAVE;
 276
 277 }
 278
 279 void perlAuthInit(void) {
 280     dSP;
 281     int             rc;
 282
 283     if (!PerlFilterActive)
 284         return;
 285
 286     ENTER;
 287     SAVETMPS;
 288     PUSHMARK(SP);
 289
 290     if (perl_get_cv("auth_init", 0) == NULL) {
 291       syslog(L_ERROR, "Perl function auth_init not defined");
 292       Reply("%d Internal Error (3).  Goodbye\r\n", NNTP_ACCESS_VAL);
 293       ExitWithStats(1, true);
 294     }
 295
 296     rc = perl_call_pv("auth_init", G_EVAL|G_DISCARD);
 297
 298     SPAGAIN;
 299
 300
 301     if (SvTRUE(ERRSV))     /* check $@ */ {
 302         syslog(L_ERROR, "Perl function authenticate died: %s",
 303                SvPV(ERRSV, PL_na));
 304         Reply("%d Internal Error (1).  Goodbye\r\n", NNTP_ACCESS_VAL);
 305         ExitWithStats(1, true);
 306     }
 307
 308     while (rc--) {
 309         (void)POPs;
 310     }
 311
 312     PUTBACK;
 313     FREETMPS;
 314     LEAVE;
 315
 316 }
 317
 318 int perlAuthenticate(char *user, char *passwd, char *errorstring, char *newUser) {
 319     dSP;
 320     HV              *attribs;
 321     int             rc;
 322     char            *p;
 323     int             code;
 324
 325     if (!PerlFilterActive)
 326         return NNTP_ACCESS_VAL;
 327
 328     if (perl_get_cv("authenticate", 0) == NULL) {
 329         syslog(L_ERROR, "Perl function authenticate not defined");
 330         Reply("%d Internal Error (3).  Goodbye\r\n", NNTP_ACCESS_VAL);
 331         ExitWithStats(1, true);
 332     }
 333
 334     ENTER;
 335     SAVETMPS;
 336     attribs = perl_get_hv("attributes", true);
 337     hv_store(attribs, "hostname", 8, newSVpv(ClientHost, 0), 0);
 338     hv_store(attribs, "ipaddress", 9, newSVpv(ClientIpString, 0), 0);
 339     hv_store(attribs, "port", 4, newSViv(ClientPort), 0);
 340     hv_store(attribs, "interface", 9, newSVpv(ServerHost, 0), 0);
 341     hv_store(attribs, "intipaddr", 9, newSVpv(ServerIpString, 0), 0);
 342     hv_store(attribs, "intport", 7, newSViv(ServerPort), 0);
 343     hv_store(attribs, "username", 8, newSVpv(user, 0), 0);
 344     hv_store(attribs, "password", 8, newSVpv(passwd, 0), 0);
 345
 346     PUSHMARK(SP);
 347     rc = perl_call_pv("authenticate", G_EVAL|G_ARRAY);
 348
 349     SPAGAIN;
 350
 351     if (rc == 0 ) { /* Error occured, same as checking $@ */
 352         syslog(L_ERROR, "Perl function authenticate died: %s",
 353                SvPV(ERRSV, PL_na));
 354         Reply("%d Internal Error (1).  Goodbye\r\n", NNTP_ACCESS_VAL);
 355         ExitWithStats(1, false);
 356     }
 357
 358     if ((rc != 3) && (rc != 2)) {
 359         syslog(L_ERROR, "Perl function authenticate returned wrong number of results: %d", rc);
 360         Reply("%d Internal Error (2).  Goodbye\r\n", NNTP_ACCESS_VAL);
 361         ExitWithStats(1, false);
 362     }
 363
 364     if (rc == 3) {
 365       p = POPp;
 366       strcpy(newUser, p);
 367     }
 368
 369     p = POPp;
 370     strcpy(errorstring, p);
 371
 372     code = POPi;
 373
 374     if ((code == NNTP_POSTOK_VAL) || (code == NNTP_NOPOSTOK_VAL))
 375         code = PERMcanpost ? NNTP_POSTOK_VAL : NNTP_NOPOSTOK_VAL;
 376
 377     if (code == NNTP_AUTH_NEEDED_VAL)
 378         PERMneedauth = true;
 379
 380     hv_undef(attribs);
 381
 382     PUTBACK;
 383     FREETMPS;
 384     LEAVE;
 385
 386     return code;
 387 }
 388
 389 #ifdef DEBUG_MODIFY
 390 void
 391 dumpTable (msg)
 392 char *msg;
 393 {
 394       HEADER        *hp;
 395       int   i;
 396
 397       fprintf(flog,"===BEGIN TABLE DUMP: %s\n",msg);
 398
 399       for (hp = Table; hp < EndOfTable; hp++) {
 400         fprintf(flog," Name: '%s'",hp->Name); fflush(flog);
 401         fprintf(flog," Size: '%d'",hp->Size); fflush(flog);
 402         fprintf(flog," Value: '%s'\n",((hp->Value == NULL) ? "(NULL)" : hp->Value)); fflush(flog);
 403       }
 404
 405       for (i=0; i<OtherCount; i++) {
 406         fprintf(flog,"Extra[%02d]: %s\n",i,OtherHeaders[i]);
 407       }
 408       fprintf(flog,"===END TABLE DUMP: %s\n",msg);
 409 }
 410 #endif /* DEBUG_MODIFY */
 411
 412 #endif /* DO_PERL */