innd/perl.c

   1 /*  $Id: perl.c 7815 2008-05-05 08:43:58Z iulius $
   2 **
   3 **  Perl filtering support for innd.
   4 **
   5 **  Originally written by Christophe Wolfhugel <wolf@pasteur.fr> (although
   6 **  he wouldn't recognise it anymore so don't blame him) and modified,
   7 **  expanded and tweaked since by James Brister, Jeremy Nixon, Ed Mooring,
   8 **  Russell Vincent, and Russ Allbery.
   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 **  Future work:
  16 **
  17 **   - What we're doing with Path headers right now doesn't work for folded
  18 **     headers.  It's also kind of gross.  There has to be a better way of
  19 **     handling this.
  20 **
  21 **   - The breakdown between this file, lib/perl.c, and nnrpd/perl.c should
  22 **     be rethought, ideally in the light of supporting multiple filters in
  23 **     different languages.
  24 **
  25 **   - We're still calling strlen() on artBody, which should be avoidable
  26 **     since we've already walked it several times.  We should just cache
  27 **     the length somewhere for speed.
  28 **
  29 **   - Variable and key names should be standardized between this and nnrpd.
  30 **
  31 **   - The XS code is still calling CC* functions.  The common code between
  32 **     the two control interfaces should be factored out into the rest of
  33 **     innd instead.
  34 **
  35 **   - There's a needless perl_get_cv() call for *every message ID* offered
  36 **     to the server right now.  We need to stash whether that filter is
  37 **     active.
  38 */
  39
  40 #include "config.h"
  41
  42 /* Skip this entire file if DO_PERL (./configure --with-perl) isn't set. */
  43 #if DO_PERL
  44
  45 #include "clibrary.h"
  46 #include "innd.h"
  47
  48 #include <EXTERN.h>
  49 #include <perl.h>
  50 #include <XSUB.h>
  51 #include "ppport.h"
  52
  53 #include "innperl.h"
  54
  55 /* From art.c.  Ew.  Need header parsing that doesn't use globals. */
  56 extern char             *filterPath;
  57
  58 /*
  59 **  Run an incoming article through the Perl article filter.  Returns NULL
  60 **  accept the article or a rejection message to reject it.
  61 */
  62 char *
  63 PLartfilter(const ARTDATA *data, char *artBody, long artLen, int lines)
  64 {
  65     dSP;
  66     const ARTHEADER * hp;
  67     const HDRCONTENT *hc = data->HdrContent;
  68     HV *        hdr;
  69     CV *        filter;
  70     int         i, rc;
  71     char *      p;
  72     static char buf[256];
  73
  74     if (!PerlFilterActive) return NULL;
  75     filter = perl_get_cv("filter_art", 0);
  76     if (!filter) return NULL;
  77
  78     /* Create %hdr and stash a copy of every known header.  Path has to be
  79        handled separately since it's been munged by article processing. */
  80     hdr = perl_get_hv("hdr", 1);
  81     for (i = 0 ; i < MAX_ARTHEADER ; i++) {
  82         if (HDR_FOUND(i)) {
  83             hp = &ARTheaders[i];
  84             hv_store(hdr, (char *) hp->Name, hp->Size, newSVpv(HDR(i), 0), 0);
  85         }
  86     }
  87
  88     /* Store the article body.  We don't want to make another copy of it,
  89      * since it could potentially be quite large.  In testing, this produced
  90      * a 17% speed improvement over making a copy of the article body
  91      * for a fairly heavy filter.
  92      * Available since Perl 5.7.1, newSVpvn_share allows to avoid such
  93      * a copy (getting round its use for older versions of Perl leads
  94      * to unreliable SV * bodies as for regexps).  And for Perl not to
  95      * compute a hash for artBody, we give it "42". */
  96     if (artBody) {
  97 #if (PERL_REVISION == 5) && ((PERL_VERSION < 7) || ((PERL_VERSION == 7) && (PERL_SUBVERSION < 1)))
  98         hv_store(hdr, "__BODY__", 8, newSVpv(artBody, artLen), 0);
  99 #else
 100         hv_store(hdr, "__BODY__", 8, newSVpvn_share(artBody, artLen, 42), 0);
 101 #endif /* Perl < 5.7.1 */
 102     }
 103
 104     hv_store(hdr, "__LINES__", 9, newSViv(lines), 0);
 105
 106     ENTER;
 107     SAVETMPS;
 108     PUSHMARK(SP);
 109     rc = perl_call_sv((SV *) filter, G_EVAL|G_SCALAR|G_NOARGS);
 110     SPAGAIN;
 111
 112     hv_undef(hdr);
 113
 114     /* Check $@, which will be set if the sub died. */
 115     buf[0] = '\0';
 116     if (SvTRUE(ERRSV)) {
 117         syslog(L_ERROR, "Perl function filter_art died on article %s: %s",
 118                HDR_FOUND(HDR__MESSAGE_ID) ? HDR(HDR__MESSAGE_ID) : "?",
 119                SvPV(ERRSV, PL_na));
 120         (void) POPs;
 121         PerlFilter(false);
 122     } else if (rc == 1) {
 123         p = POPp;
 124         if (p && *p)
 125             strlcpy(buf, p, sizeof(buf));
 126     }
 127
 128     PUTBACK;
 129     FREETMPS;
 130     LEAVE;
 131     return (buf[0] != '\0') ? buf : NULL;
 132 }
 133
 134
 135 /*
 136 **  Run an incoming message ID from CHECK or IHAVE through the Perl filter.
 137 **  Returns NULL to accept the article or a rejection message to reject it.
 138 */
 139 char *
 140 PLmidfilter(char *messageID)
 141 {
 142     dSP;
 143     CV          *filter;
 144     int         rc;
 145     char        *p;
 146     static char buf[256];
 147
 148     if (!PerlFilterActive) return NULL;
 149     filter = perl_get_cv("filter_messageid", 0);
 150     if (!filter) return NULL;
 151
 152     /* Pass filter_messageid() the message ID on the Perl stack. */
 153     ENTER;
 154     SAVETMPS;
 155     PUSHMARK(SP);
 156     XPUSHs(sv_2mortal(newSVpv(messageID, 0)));
 157     PUTBACK;
 158     rc = perl_call_sv((SV *) filter, G_EVAL|G_SCALAR);
 159     SPAGAIN;
 160
 161     /* Check $@, which will be set if the sub died. */
 162     buf[0] = '\0';
 163     if (SvTRUE(ERRSV)) {
 164         syslog(L_ERROR, "Perl function filter_messageid died on id %s: %s",
 165                messageID, SvPV(ERRSV, PL_na));
 166         (void) POPs;
 167         PerlFilter(false);
 168     } else if (rc == 1) {
 169         p = POPp;
 170         if (p && *p)
 171             strlcpy(buf, p, sizeof(buf));
 172     }
 173
 174     PUTBACK;
 175     FREETMPS;
 176     LEAVE;
 177     return (buf[0] != '\0') ? buf : NULL;
 178 }
 179
 180
 181 /*
 182 **  Call a Perl sub on any change in INN's mode, passing in the old and new
 183 **  mode and the reason.
 184 */
 185 void
 186 PLmode(OPERATINGMODE Mode, OPERATINGMODE NewMode, char *reason)
 187 {
 188     dSP;
 189     HV          *mode;
 190     CV          *filter;
 191
 192     filter = perl_get_cv("filter_mode", 0);
 193     if (!filter) return;
 194
 195     /* Current mode goes into $mode{Mode}, new mode in $mode{NewMode}, and
 196        the reason in $mode{reason}. */
 197     mode = perl_get_hv("mode", 1);
 198
 199     if (Mode == OMrunning)
 200         hv_store(mode, "Mode", 4, newSVpv("running", 0), 0);
 201     if (Mode == OMpaused)
 202         hv_store(mode, "Mode", 4, newSVpv("paused", 0), 0);
 203     if (Mode == OMthrottled)
 204         hv_store(mode, "Mode", 4, newSVpv("throttled", 0), 0);
 205
 206     if (NewMode == OMrunning)
 207         hv_store(mode, "NewMode", 7, newSVpv("running", 0), 0);
 208     if (NewMode == OMpaused)
 209         hv_store(mode, "NewMode", 7, newSVpv("paused", 0), 0);
 210     if (NewMode == OMthrottled)
 211         hv_store(mode, "NewMode", 7, newSVpv("throttled", 0), 0);
 212
 213     hv_store(mode, "reason", 6, newSVpv(reason, 0), 0);
 214
 215     PUSHMARK(SP);
 216     perl_call_sv((SV *) filter, G_EVAL|G_DISCARD|G_NOARGS);
 217
 218     /* Check $@, which will be set if the sub died. */
 219     if (SvTRUE(ERRSV)) {
 220         syslog(L_ERROR, "Perl function filter_mode died: %s",
 221                 SvPV(ERRSV, PL_na));
 222         (void) POPs;
 223         PerlFilter(false);
 224     }
 225 }
 226
 227
 228 /*
 229 **  Called by CCmode, this returns the Perl filter statistics if a Perl
 230 **  function to generate such statistics has been defined, or NULL otherwise.
 231 **  If a string is returned, it's in newly allocated memory that must be freed
 232 **  by the caller.
 233 */
 234 char *
 235 PLstats(void)
 236 {
 237     dSP;
 238     char *argv[] = { NULL };
 239
 240     if (perl_get_cv("filter_stats", false) == NULL)
 241         return NULL;
 242     else {
 243         char *stats = NULL;
 244         char *result;
 245
 246         ENTER;
 247         SAVETMPS;
 248         perl_call_argv("filter_stats", G_EVAL | G_NOARGS, argv);
 249         SPAGAIN;
 250         result = POPp;
 251         if (result != NULL && *result)
 252             stats = xstrdup(result);
 253         PUTBACK;
 254         FREETMPS;
 255         LEAVE;
 256
 257         return stats;
 258     }
 259 }
 260
 261
 262 /*
 263 **  The remainder of this file are XS callbacks visible to embedded Perl
 264 **  code to perform various innd functions.  They were originally written by
 265 **  Ed Mooring (mooring@acm.org) on May 14, 1998, and have since been split
 266 **  between this file and lib/perl.c (which has the ones that can also be
 267 **  used in nnrpd).  The function that registers them at startup is at the
 268 **  end.
 269 */
 270
 271 /*
 272 **  Add an entry to history.  Takes message ID and optionally arrival,
 273 **  article, and expire times and storage API token.  If the times aren't
 274 **  given, they default to now.  If the token isn't given, that field will
 275 **  be left empty.  Returns boolean success.
 276 */
 277 XS(XS_INN_addhist)
 278 {
 279     dXSARGS;
 280     int         i;
 281     char        tbuff[32];
 282     char*       parambuf[6];
 283
 284     if (items < 1 || items > 5)
 285         croak("Usage INN::addhist(msgid,[arrival,articletime,expire,token])");
 286
 287     for (i = 0; i < items; i++)
 288         parambuf[i] = (char *) SvPV(ST(0), PL_na);
 289
 290     /* If any of the times are missing, they should default to now. */
 291     if (i < 4) {
 292         snprintf(tbuff, sizeof(tbuff), "%ld", (long) time(NULL));
 293         for (; i < 4; i++)
 294             parambuf[i] = tbuff;
 295     }
 296
 297     /* The token defaults to an empty string. */
 298     if (i == 4)
 299         parambuf[4] = "";
 300
 301     parambuf[5] = NULL;
 302
 303     /* CCaddhist returns NULL on success. */
 304     if (CCaddhist(parambuf))
 305         XSRETURN_NO;
 306     else
 307         XSRETURN_YES;
 308 }
 309
 310
 311 /*
 312 **  Takes the message ID of an article and returns the full article as a
 313 **  string or undef if the article wasn't found.  It will be converted from
 314 **  wire format to native format.  Note that this call isn't particularly
 315 **  optimized or cheap.
 316 */
 317 XS(XS_INN_article)
 318 {
 319     dXSARGS;
 320     char *      msgid;
 321     TOKEN       token;
 322     ARTHANDLE * art;
 323     char *      p;
 324     size_t      len;
 325
 326     if (items != 1)
 327         croak("Usage: INN::article(msgid)");
 328
 329     /* Get the article token from the message ID and the history file. */
 330     msgid = (char *) SvPV(ST(0), PL_na);
 331     if (!HISlookup(History, msgid, NULL, NULL, NULL, &token)) XSRETURN_UNDEF;
 332
 333     /* Retrieve the article and convert it from wire format. */
 334     art = SMretrieve(token, RETR_ALL);
 335     if (art == NULL) XSRETURN_UNDEF;
 336     p = FromWireFmt(art->data, art->len, &len);
 337     SMfreearticle(art);
 338
 339     /* Push a copy of the article onto the Perl stack, free our temporary
 340        memory allocation, and return the article to Perl. */
 341     ST(0) = sv_2mortal(newSVpv(p, len));
 342     free(p);
 343     XSRETURN(1);
 344 }
 345
 346
 347 /*
 348 **  Cancel a message by message ID; returns boolean success.  Equivalent to
 349 **  ctlinnd cancel <message>.
 350 */
 351 XS(XS_INN_cancel)
 352 {
 353     dXSARGS;
 354     char        *msgid;
 355     char        *parambuf[2];
 356
 357     if (items != 1)
 358         croak("Usage: INN::cancel(msgid)");
 359
 360     msgid = (char *) SvPV(ST(0), PL_na);
 361     parambuf[0] = msgid;
 362     parambuf[1] = NULL;
 363
 364     /* CCcancel returns NULL on success. */
 365     if (CCcancel(parambuf))
 366         XSRETURN_NO;
 367     else
 368         XSRETURN_YES;
 369 }
 370
 371
 372 /*
 373 **  Return the files for a given message ID, taken from the history file.
 374 **  This function should really be named INN::token() and probably will be
 375 **  some day.
 376 */
 377 XS(XS_INN_filesfor)
 378 {
 379     dXSARGS;
 380     char        *msgid;
 381     TOKEN       token;
 382
 383     if (items != 1)
 384         croak("Usage: INN::filesfor(msgid)");
 385
 386     msgid = (char *) SvPV(ST(0), PL_na);
 387     if (HISlookup(History, msgid, NULL, NULL, NULL, &token)) {
 388         XSRETURN_PV(TokenToText(token));
 389     } else {
 390         XSRETURN_UNDEF;
 391     }
 392 }
 393
 394
 395 /*
 396 **  Whether message ID is in the history file; returns boolean.
 397 */
 398 XS(XS_INN_havehist)
 399 {
 400     dXSARGS;
 401     char        *msgid;
 402
 403     if (items != 1)
 404         croak("Usage: INN::havehist(msgid)");
 405
 406     msgid = (char *) SvPV(ST(0), PL_na);
 407     if (HIScheck(History, msgid))
 408         XSRETURN_YES;
 409     else
 410         XSRETURN_NO;
 411 }
 412
 413
 414 /*
 415 **  Takes the message ID of an article and returns the article headers as
 416 **  a string or undef if the article wasn't found.  Each line of the header
 417 **  will end with \n.
 418 */
 419 XS(XS_INN_head)
 420 {
 421     dXSARGS;
 422     char *      msgid;
 423     TOKEN       token;
 424     ARTHANDLE * art;
 425     char *      p;
 426     size_t      len;
 427
 428     if (items != 1)
 429         croak("Usage: INN::head(msgid)");
 430
 431     /* Get the article token from the message ID and the history file. */
 432     msgid = (char *) SvPV(ST(0), PL_na);
 433     if (!HISlookup(History, msgid, NULL, NULL, NULL, &token)) XSRETURN_UNDEF;
 434
 435     /* Retrieve the article header and convert it from wire format. */
 436     art = SMretrieve(token, RETR_HEAD);
 437     if (art == NULL) XSRETURN_UNDEF;
 438     p = FromWireFmt(art->data, art->len, &len);
 439     SMfreearticle(art);
 440
 441     /* Push a copy of the article header onto the Perl stack, free our
 442        temporary memory allocation, and return the header to Perl. */
 443     ST(0) = sv_2mortal(newSVpv(p, len));
 444     free(p);
 445     XSRETURN(1);
 446 }
 447
 448
 449 /*
 450 **  Returns the active file flag for a newsgroup or undef if it isn't in the
 451 **  active file.
 452 */
 453 XS(XS_INN_newsgroup)
 454 {
 455     dXSARGS;
 456     char *      newsgroup;
 457     NEWSGROUP * ngp;
 458     char *      end;
 459     int         size;
 460
 461     if (items != 1)
 462         croak("Usage: INN::newsgroup(group)");
 463     newsgroup = (char *) SvPV(ST(0), PL_na);
 464
 465     ngp = NGfind(newsgroup);
 466     if (!ngp) {
 467         XSRETURN_UNDEF;
 468     } else {
 469         /* ngp->Rest is newline-terminated; find the end. */
 470         end = strchr(ngp->Rest, '\n');
 471         if (end == NULL) {
 472             size = strlen(ngp->Rest);
 473         } else {
 474             size = end - ngp->Rest;
 475         }
 476         ST(0) = sv_2mortal(newSVpv(ngp->Rest, size));
 477         XSRETURN(1);
 478     }
 479 }
 480
 481
 482 /*
 483 **  Initialize the XS callbacks defined in this file.
 484 */
 485 void
 486 PLxsinit(void)
 487 {
 488     newXS("INN::addhist", XS_INN_addhist, "perl.c");
 489     newXS("INN::article", XS_INN_article, "perl.c");
 490     newXS("INN::cancel", XS_INN_cancel, "perl.c");
 491     newXS("INN::havehist", XS_INN_havehist, "perl.c");
 492     newXS("INN::head", XS_INN_head, "perl.c");
 493     newXS("INN::newsgroup", XS_INN_newsgroup, "perl.c");
 494     newXS("INN::filesfor", XS_INN_filesfor, "perl.c");
 495 }
 496
 497 #endif /* defined(DO_PERL) */