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