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