/*  $Id: perl.c 6242 2003-02-21 15:33:15Z alexk $
**
**  Perl filtering support for innd.
**
**  Originally written by Christophe Wolfhugel <wolf@pasteur.fr> (although
**  he wouldn't recognise it anymore so don't blame him) and modified,
**  expanded and tweaked since by James Brister, Jeremy Nixon, Ed Mooring,
**  Russell Vincent, and Russ Allbery.
**
**  This file should contain all innd-specific Perl linkage.  Linkage
**  applicable to both innd and nnrpd should go into lib/perl.c instead.
**
**  We are assuming Perl 5.004 or later.
**
**  Future work:
**
**   - What we're doing with Path headers right now doesn't work for folded
**     headers.  It's also kind of gross.  There has to be a better way of
**     handling this.
**
**   - The breakdown between this file, lib/perl.c, and nnrpd/perl.c should
**     be rethought, ideally in the light of supporting multiple filters in
**     different languages.
**
**   - We're still calling strlen() on artBody, which should be avoidable
**     since we've already walked it several times.  We should just cache
**     the length somewhere for speed.
**
**   - Variable and key names should be standardized between this and nnrpd.
**
**   - The XS code is still calling CC* functions.  The common code between
**     the two control interfaces should be factored out into the rest of
**     innd instead.
**
**   - There's a needless perl_get_cv() call for *every message ID* offered
**     to the server right now.  We need to stash whether that filter is
**     active.
*/

#include "config.h"

/* Skip this entire file if DO_PERL (./configure --with-perl) isn't set. */
#if DO_PERL

#include "clibrary.h"
#include "innd.h"

#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>
#include "ppport.h"

#include "innperl.h"

/* From art.c.  Ew.  Need header parsing that doesn't use globals. */
extern char             *filterPath;

/*
**  Run an incoming article through the Perl article filter.  Returns NULL
**  accept the article or a rejection message to reject it.
*/
char *
PLartfilter(const ARTDATA *data, char *artBody, long artLen, int lines)
{
    dSP;
    const ARTHEADER * hp;
    const HDRCONTENT *hc = data->HdrContent;
    HV *        hdr;
    CV *        filter;
    int         i, rc;
    char *      p;
    static SV * body = NULL;
    static char buf[256];

    if (!PerlFilterActive) return NULL;
    filter = perl_get_cv("filter_art", 0);
    if (!filter) return NULL;

    /* Create %hdr and stash a copy of every known header.  Path has to be
       handled separately since it's been munged by article processing. */
    hdr = perl_get_hv("hdr", 1);
    for (i = 0 ; i < MAX_ARTHEADER ; i++) {
	if (HDR_FOUND(i)) {
	    hp = &ARTheaders[i];
            hv_store(hdr, (char *) hp->Name, hp->Size, newSVpv(HDR(i), 0), 0);
	}
    }

    /* Store the article body.  We don't want to make another copy of it,
       since it could potentially be quite large.  Instead, stash the
       pointer in the static SV * body.  We set LEN to 0 and inc the
       refcount to tell Perl not to free it (either one should be enough).
       Requires 5.004.  In testing, this produced a 17% speed improvement
       over making a copy of the article body for a fairly heavy filter. */
    if (artBody) {
        if (!body) {
            body = newSV(0);
            (void) SvUPGRADE(body, SVt_PV);
        }
        SvPVX(body) = artBody;
        SvCUR_set(body, artLen);
        SvLEN_set(body, 0);
        SvPOK_on(body);
        (void) SvREADONLY_on(body);
        (void) SvREFCNT_inc(body);
        hv_store(hdr, "__BODY__", 8, body, 0);
    }

    hv_store(hdr, "__LINES__", 9, newSViv(lines), 0);

    ENTER;
    SAVETMPS;
    PUSHMARK(SP);
    rc = perl_call_sv((SV *) filter, G_EVAL|G_SCALAR|G_NOARGS);
    SPAGAIN;

    hv_undef(hdr);

    /* Check $@, which will be set if the sub died. */
    buf[0] = '\0';
    if (SvTRUE(ERRSV)) {
        syslog(L_ERROR, "Perl function filter_art died on article %s: %s",
               HDR_FOUND(HDR__MESSAGE_ID) ? HDR(HDR__MESSAGE_ID) : "?",
               SvPV(ERRSV, PL_na));
        (void) POPs;
        PerlFilter(false);
    } else if (rc == 1) {
        p = POPp;
        if (p && *p)
            strlcpy(buf, p, sizeof(buf));
    }

    PUTBACK;
    FREETMPS;
    LEAVE;
    return (buf[0] != '\0') ? buf : NULL;
}


/*
**  Run an incoming message ID from CHECK or IHAVE through the Perl filter.
**  Returns NULL to accept the article or a rejection message to reject it.
*/
char *
PLmidfilter(char *messageID)
{
    dSP;
    CV          *filter;
    int         rc;
    char        *p;
    static char buf[256];

    if (!PerlFilterActive) return NULL;
    filter = perl_get_cv("filter_messageid", 0);
    if (!filter) return NULL;

    /* Pass filter_messageid() the message ID on the Perl stack. */
    ENTER;
    SAVETMPS;
    PUSHMARK(SP);
    XPUSHs(sv_2mortal(newSVpv(messageID, 0)));
    PUTBACK;
    rc = perl_call_sv((SV *) filter, G_EVAL|G_SCALAR);
    SPAGAIN;

    /* Check $@, which will be set if the sub died. */
    buf[0] = '\0';
    if (SvTRUE(ERRSV)) {
        syslog(L_ERROR, "Perl function filter_messageid died on id %s: %s",
               messageID, SvPV(ERRSV, PL_na));
        (void) POPs;
        PerlFilter(false);
    } else if (rc == 1) {
        p = POPp;
        if (p && *p)
            strlcpy(buf, p, sizeof(buf));
    }
    
    PUTBACK;
    FREETMPS;
    LEAVE;
    return (buf[0] != '\0') ? buf : NULL;
}


/*
**  Call a Perl sub on any change in INN's mode, passing in the old and new
**  mode and the reason.
*/
void
PLmode(OPERATINGMODE Mode, OPERATINGMODE NewMode, char *reason)
{
    dSP;
    HV          *mode;
    CV          *filter;

    filter = perl_get_cv("filter_mode", 0);
    if (!filter) return;

    /* Current mode goes into $mode{Mode}, new mode in $mode{NewMode}, and
       the reason in $mode{reason}. */
    mode = perl_get_hv("mode", 1);

    if (Mode == OMrunning)
        hv_store(mode, "Mode", 4, newSVpv("running", 0), 0);
    if (Mode == OMpaused)
        hv_store(mode, "Mode", 4, newSVpv("paused", 0), 0);
    if (Mode == OMthrottled)
        hv_store(mode, "Mode", 4, newSVpv("throttled", 0), 0);

    if (NewMode == OMrunning)
        hv_store(mode, "NewMode", 7, newSVpv("running", 0), 0);
    if (NewMode == OMpaused)
        hv_store(mode, "NewMode", 7, newSVpv("paused", 0), 0);
    if (NewMode == OMthrottled)
        hv_store(mode, "NewMode", 7, newSVpv("throttled", 0), 0);

    hv_store(mode, "reason", 6, newSVpv(reason, 0), 0);

    PUSHMARK(SP);
    perl_call_sv((SV *) filter, G_EVAL|G_DISCARD|G_NOARGS);

    /* Check $@, which will be set if the sub died. */
    if (SvTRUE(ERRSV)) {
        syslog(L_ERROR, "Perl function filter_mode died: %s",
                SvPV(ERRSV, PL_na));
        (void) POPs;
        PerlFilter(false);
    }
}


/*
**  Called by CCmode, this returns the Perl filter statistics if a Perl
**  function to generate such statistics has been defined, or NULL otherwise.
**  If a string is returned, it's in newly allocated memory that must be freed
**  by the caller.
*/
char *
PLstats(void)
{
    dSP;
    
    if (perl_get_cv("filter_stats", false) == NULL)
        return NULL;
    else {
        char *stats = NULL;
        char *result;

	ENTER;
	SAVETMPS;
	perl_call_argv("filter_stats", G_EVAL | G_NOARGS, NULL);
	SPAGAIN;
        result = POPp;
        if (result != NULL && *result)
            stats = xstrdup(result);
	PUTBACK;
	FREETMPS;
	LEAVE;

        return stats;
    }
}


/*
**  The remainder of this file are XS callbacks visible to embedded Perl
**  code to perform various innd functions.  They were originally written by
**  Ed Mooring (mooring@acm.org) on May 14, 1998, and have since been split
**  between this file and lib/perl.c (which has the ones that can also be
**  used in nnrpd).  The function that registers them at startup is at the
**  end.
*/

/*
**  Add an entry to history.  Takes message ID and optionally arrival,
**  article, and expire times and storage API token.  If the times aren't
**  given, they default to now.  If the token isn't given, that field will
**  be left empty.  Returns boolean success.
*/
XS(XS_INN_addhist)
{
    dXSARGS;
    int         i;
    char        tbuff[32];
    char*       parambuf[6];

    if (items < 1 || items > 5)
        croak("Usage INN::addhist(msgid,[arrival,articletime,expire,token])");

    for (i = 0; i < items; i++)
        parambuf[i] = (char *) SvPV(ST(0), PL_na);

    /* If any of the times are missing, they should default to now. */
    if (i < 4) {
        snprintf(tbuff, sizeof(tbuff), "%ld", (long) time(NULL));
        for (; i < 4; i++)
            parambuf[i] = tbuff;
    }

    /* The token defaults to an empty string. */
    if (i == 4)
        parambuf[4] = "";

    parambuf[5] = NULL;

    /* CCaddhist returns NULL on success. */
    if (CCaddhist(parambuf))
        XSRETURN_NO;
    else
        XSRETURN_YES;
}


/*
**  Takes the message ID of an article and returns the full article as a
**  string or undef if the article wasn't found.  It will be converted from
**  wire format to native format.  Note that this call isn't particularly
**  optimized or cheap.
*/
XS(XS_INN_article)
{
    dXSARGS;
    char *      msgid;
    TOKEN       token;
    ARTHANDLE * art;
    char *      p;
    size_t      len;

    if (items != 1)
	croak("Usage: INN::article(msgid)");

    /* Get the article token from the message ID and the history file. */
    msgid = (char *) SvPV(ST(0), PL_na);
    if (!HISlookup(History, msgid, NULL, NULL, NULL, &token)) XSRETURN_UNDEF;

    /* Retrieve the article and convert it from wire format. */
    art = SMretrieve(token, RETR_ALL);
    if (art == NULL) XSRETURN_UNDEF;
    p = FromWireFmt(art->data, art->len, &len);
    SMfreearticle(art);

    /* Push a copy of the article onto the Perl stack, free our temporary
       memory allocation, and return the article to Perl. */
    ST(0) = sv_2mortal(newSVpv(p, len));
    free(p);
    XSRETURN(1);
}


/*
**  Cancel a message by message ID; returns boolean success.  Equivalent to
**  ctlinnd cancel <message>.
*/
XS(XS_INN_cancel)
{
    dXSARGS;
    char        *msgid;
    char        *parambuf[2];

    if (items != 1)
        croak("Usage: INN::cancel(msgid)");

    msgid = (char *) SvPV(ST(0), PL_na);
    parambuf[0] = msgid;
    parambuf[1] = NULL;

    /* CCcancel returns NULL on success. */
    if (CCcancel(parambuf))
        XSRETURN_NO;
    else
        XSRETURN_YES;
}


/*
**  Return the files for a given message ID, taken from the history file.
**  This function should really be named INN::token() and probably will be
**  some day.
*/
XS(XS_INN_filesfor)
{
    dXSARGS;
    char        *msgid;
    TOKEN       token;

    if (items != 1)
        croak("Usage: INN::filesfor(msgid)");

    msgid = (char *) SvPV(ST(0), PL_na);
    if (HISlookup(History, msgid, NULL, NULL, NULL, &token)) {
        XSRETURN_PV(TokenToText(token));
    } else {
        XSRETURN_UNDEF;
    }
}


/*
**  Whether message ID is in the history file; returns boolean.
*/
XS(XS_INN_havehist)
{
    dXSARGS;
    char        *msgid;

    if (items != 1)
        croak("Usage: INN::havehist(msgid)");

    msgid = (char *) SvPV(ST(0), PL_na);
    if (HIScheck(History, msgid))
        XSRETURN_YES;
    else
        XSRETURN_NO;
}


/*
**  Takes the message ID of an article and returns the article headers as
**  a string or undef if the article wasn't found.  Each line of the header
**  will end with \n.
*/
XS(XS_INN_head)
{
    dXSARGS;
    char *      msgid;
    TOKEN       token;
    ARTHANDLE * art;
    char *      p;
    size_t      len;

    if (items != 1)
        croak("Usage: INN::head(msgid)");

    /* Get the article token from the message ID and the history file. */
    msgid = (char *) SvPV(ST(0), PL_na);
    if (!HISlookup(History, msgid, NULL, NULL, NULL, &token)) XSRETURN_UNDEF;

    /* Retrieve the article header and convert it from wire format. */
    art = SMretrieve(token, RETR_HEAD);
    if (art == NULL) XSRETURN_UNDEF;
    p = FromWireFmt(art->data, art->len, &len);
    SMfreearticle(art);

    /* Push a copy of the article header onto the Perl stack, free our
       temporary memory allocation, and return the header to Perl. */
    ST(0) = sv_2mortal(newSVpv(p, len));
    free(p);
    XSRETURN(1);
}


/*
**  Returns the active file flag for a newsgroup or undef if it isn't in the
**  active file.
*/
XS(XS_INN_newsgroup)
{
    dXSARGS;
    char *      newsgroup;
    NEWSGROUP * ngp;
    char *      end;
    int         size;

    if (items != 1)
        croak("Usage: INN::newsgroup(group)");
    newsgroup = (char *) SvPV(ST(0), PL_na);

    ngp = NGfind(newsgroup);
    if (!ngp) {
        XSRETURN_UNDEF;
    } else {
        /* ngp->Rest is newline-terminated; find the end. */
        end = strchr(ngp->Rest, '\n');
        if (end == NULL) {
            size = strlen(ngp->Rest);
        } else {
            size = end - ngp->Rest;
        }
        ST(0) = sv_2mortal(newSVpv(ngp->Rest, size));
        XSRETURN(1);
    }
}


/*
**  Initialize the XS callbacks defined in this file.
*/
void
PLxsinit(void)
{
    newXS("INN::addhist", XS_INN_addhist, "perl.c");
    newXS("INN::article", XS_INN_article, "perl.c");
    newXS("INN::cancel", XS_INN_cancel, "perl.c");
    newXS("INN::havehist", XS_INN_havehist, "perl.c");
    newXS("INN::head", XS_INN_head, "perl.c");
    newXS("INN::newsgroup", XS_INN_newsgroup, "perl.c");
    newXS("INN::filesfor", XS_INN_filesfor, "perl.c");
}

#endif /* defined(DO_PERL) */