The R Project SVN R

/*

 *  R : A Computer Language for Statistical Data Analysis

 *  Copyright (C) 2009-2024 The R Core Team.

 *

 *  This program is free software; you can redistribute it and/or modify

 *  it under the terms of the GNU General Public License as published by

 *  the Free Software Foundation; either version 2 of the License, or

 *  (at your option) any later version.

 *

 *  This program is distributed in the hope that it will be useful,

 *  but WITHOUT ANY WARRANTY; without even the implied warranty of

 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

 *  GNU General Public License for more details.

 *

 *  You should have received a copy of the GNU General Public License

 *  along with this program; if not, a copy is available at

 *  https://www.R-project.org/Licenses/

 */

/* This is a small HTTP server that serves requests by evaluating

 * the httpd() function and passing the result to the browser. */

/* Note that the server runs partially on the main R thread (it has to,

   because it uses R), and it also sends the response mostly from the

   main thread. It is thus not possible to use the server from the R thread

   itself, e.g. via download.file(), because of a deadlock between the

   server and the client, when the data isn't sent in a single chunk.

   On Unix, the deadlock could also happen when the client is sending a

   request to the server (and the request isn't sent in a single chunk).

   This cannot happen with the intended use of this server, when it is used

   to serve help pages to an external client (a web browser).

*/

/* Example:

   httpd <- function(path,query=NULL,...) {

      cat("Request for:", path,"\n"); print(query);

      list(paste("Hello, <b>world</b>!<p>You asked for \"",path,"\".",sep=''))

   }

   .Internal(startHTTPD("127.0.0.1",8080))

 */

/* size of the line buffer for each worker (request and header only)

 * requests that have longer headers will be rejected with 413 */

#define LINE_BUF_SIZE 1024

/* maximum number of active workers (parallel connections)

 * when exceeded the server closes new connections */

#define MAX_WORKERS 32

/* --- Rhttpd implementation --- */

#ifdef HAVE_CONFIG_H

#include <config.h>

#endif

#include <Defn.h>

#include <Fileio.h>

#include <Rconnections.h>

#include <stdlib.h>

#include <stdio.h>

#include <string.h>

#include <Rmodules/Rinternet.h>

#define HttpdServerActivity 8

#define HttpdWorkerActivity 9

/* this is originally from sisock.h - system independent sockets */

#ifndef _WIN32

# include <R_ext/eventloop.h>

# include <sys/types.h>

# ifdef HAVE_UNISTD_H

#  include <unistd.h>

# endif

# include <netdb.h>

# include <sys/socket.h>

# include <netinet/in.h>

# include <arpa/inet.h>

# include <errno.h>

# define sockerrno errno

# define SOCKET int

# define INVALID_SOCKET (-1)

# define closesocket(A) close(A)

# define initsocks()

# define donesocks()

#else

/* --- Windows-only --- */

# include <winsock2.h>

# include <windows.h>

# include <string.h>

# define sockerrno WSAGetLastError()

static int initsocks(void)

{

    WSADATA dt;

    /* initialize WinSock 2.2 */

    WORD wVers = MAKEWORD(2, 2);

    return (WSAStartup(wVers, &dt)) ? -1 : 0;

}

# define donesocks() WSACleanup()

typedef int socklen_t;

#endif /* _WIN32 */

/* --- system-independent part --- */

#define SA struct sockaddr

#define SAIN struct sockaddr_in

static struct sockaddr *build_sin(struct sockaddr_in *sa, const char *ip, int port) {

    memset(sa, 0, sizeof(struct sockaddr_in));

    sa->sin_family = AF_INET;

    sa->sin_port = htons(port);

    sa->sin_addr.s_addr = (ip) ? inet_addr(ip) : htonl(INADDR_ANY);

    return (struct sockaddr*)sa;

}

/* --- END of sisock.h --- */

/* debug output - change the DBG(X) X to enable debugging output */

#define DBG(X)

/* --- httpd --- */

#define PART_REQUEST 0

#define PART_HEADER  1

#define PART_BODY    2

#define METHOD_POST  1

#define METHOD_GET   2

#define METHOD_HEAD  3

#define METHOD_OTHER 8 /* for custom requests only */

/* attributes of a connection/worker */

#define CONNECTION_CLOSE  0x01 /* Connection: close response behavior is requested */

#define HOST_HEADER       0x02 /* headers contained Host: header (required for HTTP/1.1) */

#define HTTP_1_0          0x04 /* the client requested HTTP/1.0 */

#define CONTENT_LENGTH    0x08 /* Content-length: was specified in the headers */

#define THREAD_OWNED      0x10 /* the worker is owned by a thread and cannot removed */

#define THREAD_DISPOSE    0x20 /* the thread should dispose of the worker */

#define CONTENT_TYPE      0x40 /* message has a specific content type set */

#define CONTENT_FORM_UENC 0x80 /* message content type is application/x-www-form-urlencoded */

struct buffer {

    struct buffer *next, *prev;

    size_t size, length;

    char data[1];

};

/* 

   All processing inside R is executed on the main R thread via

   R_ProcessEvents (on Unix via event handlers, on Windows via a message

   window).

   We still have to protect re-entrance and not continue processing if there

   is a worker inside R already. If we did not then another client connection

   would trigger handler and pile up eval on top of the stack, leading to

   exhaustion very quickly and a big mess.

*/

#ifdef _WIN32

static HANDLE process_request_mutex;

#else

static int in_process;

#endif

/* --- connection/worker structure holding all data for an active connection --- */

typedef struct httpd_conn {

    SOCKET sock;         /* client socket */

    struct in_addr peer; /* IP address of the peer */

#ifdef _WIN32

    HANDLE thread;       /* worker thread */

#else

    InputHandler *ih;    /* worker input handler */

#endif

    char line_buf[LINE_BUF_SIZE];  /* line buffer (used for request and headers) */

    char *url, *body;              /* URL and request body */

    char *content_type;            /* content type (if set) */

    size_t line_pos, body_pos; /* positions in the buffers */

    long content_length;           /* desired content length */

    char part, method, attr;       /* request part, method and connection attributes */

    struct buffer *headers;        /* buffer holding header lines */

} httpd_conn_t;

#define IS_HTTP_1_1(C) (((C)->attr & HTTP_1_0) == 0)

/* returns the HTTP/x.x string for a given connection - we support 1.0 and 1.1 only */

#define HTTP_SIG(C) (IS_HTTP_1_1(C) ? "HTTP/1.1" : "HTTP/1.0")

/* --- static list of currently active workers --- */

static httpd_conn_t *workers[MAX_WORKERS];

/* --- flag determining whether one-time initialization is yet to be performed --- */

static int needs_init = 1;

#ifdef _WIN32

#define WM_RHTTP_CALLBACK ( WM_USER + 1 )

static HWND message_window;

static LRESULT CALLBACK

RhttpdWindowProc(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lParam);

#ifndef HWND_MESSAGE

#define HWND_MESSAGE ((HWND)-3) /* NOTE: this is supported by W2k/XP and up only! */

#endif

#endif

static void first_init(void)

{

    initsocks();

#ifdef _WIN32

    /* create a dummy message-only window for synchronization with the

     * main event loop */

    HINSTANCE instance = GetModuleHandle(NULL);

    LPCTSTR class = "Rhttpd";

    WNDCLASS wndclass = { 0, RhttpdWindowProc, 0, 0, instance, NULL, 0, 0,

			  NULL, class };

    RegisterClass(&wndclass);

    message_window = CreateWindow(class, "Rhttpd", 0, 1, 1, 1, 1,

				  HWND_MESSAGE, NULL, instance, NULL);

    process_request_mutex = CreateMutex(NULL, FALSE, NULL);

    if (!process_request_mutex) 

        DBG(printf("Mutex creation failed\n"));

#endif

    needs_init = 0;

}

/* free buffers starting from the tail(!!) */

static void free_buffer(struct buffer *buf) {

    if (!buf) return;

    if (buf->prev) free_buffer(buf->prev);

    free(buf);

}

/* allocate a new buffer */

static struct buffer *alloc_buffer(int size, struct buffer *parent) {

    struct buffer *buf = (struct buffer*) malloc(sizeof(struct buffer) + size);

    if (!buf) return buf;

    buf->next = 0;

    buf->prev = parent;

    if (parent) parent->next = buf;

    buf->size = size;

    buf->length = 0;

    return buf;

}

/* convert doubly-linked buffers into one big raw vector */

static SEXP collect_buffers(struct buffer *buf) {

    SEXP res;

    char *dst;

    int len = 0;

    if (!buf) return allocVector(RAWSXP, 0);

    while (buf->prev) { /* count the total length and find the root */

	len += buf->length;

	buf = buf->prev;

    }

    res = allocVector(RAWSXP, len + buf->length);

    dst = (char*) RAW(res);

    while (buf) {

	if (buf->length)

	    memcpy(dst, buf->data, buf->length);

	dst += buf->length;

	buf = buf->next;

    }

    return res;

}

static void finalize_worker(httpd_conn_t *c)

{

    DBG(printf("finalizing worker %p\n", (void*) c));

#ifndef _WIN32

    if (c->ih) {

	removeInputHandler(&R_InputHandlers, c->ih);

	c->ih = NULL;

    }

#endif

    if (c->url) {

	free(c->url);

	c->url = NULL;

    }

    if (c->body) {

	free(c->body);

	c->body = NULL;

    }

    if (c->content_type) {

	free(c->content_type);

	c->content_type = NULL;

    }

    if (c->headers) {

	free_buffer(c->headers);

	c->headers = NULL;

    }

    if (c->sock != INVALID_SOCKET) {

	closesocket(c->sock);

	c->sock = INVALID_SOCKET;

    }

}

/* adds a worker to the worker list and returns 0. If the list is

 * full, the worker is finalized and returns -1.

 * Note that we don't need locking, because add_worker is guaranteed

 * to be called by the same thread (server thread).

  */

static int add_worker(httpd_conn_t *c) {

    unsigned int i = 0;

    for (; i < MAX_WORKERS; i++)

	if (!workers[i]) {

#ifdef _WIN32

	    DBG(printf("registering worker %p as %d (thread=%p)\n", (void*) c, i, (void *) c->thread));

#else

	    DBG(printf("registering worker %p as %d (handler=%p)\n", (void*) c, i, (void*) c->ih));

#endif

	    workers[i] = c;

	    return 0;

	}

    /* FIXME: ok no more space for a new worker - what do we do now?

     * for now we just drop it on the floor .. */

    finalize_worker(c);

    free(c);

    return -1;

}

/* finalize worker, remove it from the list and free the memory. If

 * the worker is owned by a thread, it is not finalized and the

 * THREAD_DISPOSE flag is set instead. */

static void remove_worker(httpd_conn_t *c)

{

    unsigned int i = 0;

    if (!c) return;

    if (c->attr & THREAD_OWNED) { /* if the worker is used by a

				   * thread, we can only signal for

				   * its removal */

	c->attr |= THREAD_DISPOSE;

	return;

    }

    finalize_worker(c);

    for (; i < MAX_WORKERS; i++)

	if (workers[i] == c)

	    workers[i] = NULL;

    DBG(printf("removing worker %p\n", (void*) c));

    free(c);

}

#ifndef Win32

extern int R_ignore_SIGPIPE; /* defined in src/main/main.c on unix */

#else

static int R_ignore_SIGPIPE; /* for simplicity of the code below */

#endif

static int send_response(SOCKET s, const char *buf, size_t len)

{

    unsigned int i = 0;

    /* we have to tell R to ignore SIGPIPE otherwise it can raise an error

       and get us into deep trouble */

    R_ignore_SIGPIPE = 1;

    while (i < len) {

	ssize_t n = send(s, buf + i, len - i, 0);

	if (n < 1) {

	    R_ignore_SIGPIPE = 0;

	    return -1;

	}

	i += n;

    }

    R_ignore_SIGPIPE = 0;

    return 0;

}

/* sends HTTP/x.x plus the text (which should be of the form " XXX ...") */

static int send_http_response(httpd_conn_t *c, const char *text) {

    char buf[96];

    const char *s = HTTP_SIG(c);

    size_t l = strlen(text);

    ssize_t res;

    /* reduce the number of packets by sending the payload en-block from buf */

    if (l < sizeof(buf) - 10) {

	strcpy(buf, s);

	strcpy(buf + 8, text);

	return send_response(c->sock, buf, l + 8);

    }

    R_ignore_SIGPIPE = 1;

    res = send(c->sock, s, 8, 0);

    R_ignore_SIGPIPE = 0;

    if (res < 8) return -1;

    return send_response(c->sock, text, strlen(text));

}

/* decode URI in place (decoding never expands) */

static void uri_decode(char *s)

{

    char *t = s;

    while (*s) {

	if (*s == '+') { /* + -> SPC */

	    *(t++) = ' '; s++;

	} else if (*s == '%') {

	    unsigned char ec = 0;

	    s++;

	    if (*s >= '0' && *s <= '9') ec |= ((unsigned char)(*s - '0')) << 4;

	    else if (*s >= 'a' && *s <= 'f') ec |= ((unsigned char)(*s - 'a' + 10)) << 4;

	    else if (*s >= 'A' && *s <= 'F') ec |= ((unsigned char)(*s - 'A' + 10)) << 4;

	    if (*s) s++;

	    if (*s >= '0' && *s <= '9') ec |= (unsigned char)(*s - '0');

	    else if (*s >= 'a' && *s <= 'f') ec |= (unsigned char)(*s - 'a' + 10);

	    else if (*s >= 'A' && *s <= 'F') ec |= (unsigned char)(*s - 'A' + 10);

	    if (*s) s++;

	    *(t++) = (char) ec;

	} else *(t++) = *(s++);

    }

    *t = 0;

}

/* parse a query string into a named character vector - must NOT be

 * URI decoded */

static SEXP parse_query(char *query)

{

    int parts = 0;

    SEXP res, names;

    char *s = query, *key = 0, *value = query, *t = query;

    while (*s) {

	if (*s == '&') parts++;

	s++;

    }

    parts++;

    res = PROTECT(allocVector(STRSXP, parts));

    names = PROTECT(allocVector(STRSXP, parts));

    s = query;

    parts = 0;

    while (1) {

	if (*s == '=' && !key) { /* first '=' in a part */

	    key = value;

	    *(t++) = 0;

	    value = t;

	    s++;

	} else if (*s == '&' || !*s) { /* next part */

	    int last_entry = !*s;

	    *(t++) = 0;

	    if (!key) key = "";

	    SET_STRING_ELT(names, parts, mkChar(key));

	    SET_STRING_ELT(res, parts, mkChar(value));

	    parts++;

	    if (last_entry) break;

	    key = 0;

	    value = t;

	    s++;

	} else if (*s == '+') { /* + -> SPC */

	    *(t++) = ' '; s++;

	} else if (*s == '%') { /* we cannot use uri_decode becasue we need &/= *before* decoding */

	    unsigned char ec = 0;

	    s++;

	    if (*s >= '0' && *s <= '9') ec |= ((unsigned char)(*s - '0')) << 4;

	    else if (*s >= 'a' && *s <= 'f') ec |= ((unsigned char)(*s - 'a' + 10)) << 4;

	    else if (*s >= 'A' && *s <= 'F') ec |= ((unsigned char)(*s - 'A' + 10)) << 4;

	    if (*s) s++;

	    if (*s >= '0' && *s <= '9') ec |= (unsigned char)(*s - '0');

	    else if (*s >= 'a' && *s <= 'f') ec |= (unsigned char)(*s - 'a' + 10);

	    else if (*s >= 'A' && *s <= 'F') ec |= (unsigned char)(*s - 'A' + 10);

	    if (*s) s++;

	    *(t++) = (char) ec;

	} else *(t++) = *(s++);

    }

    setAttrib(res, R_NamesSymbol, names);

    UNPROTECT(2);

    return res;

}

static SEXP R_ContentTypeName, R_HandlersName;

/* create an object representing the request body. It is NULL if the body is empty (or zero length).

 * In the case of a URL encoded form it will have the same shape as the query string (named string vector).

 * In all other cases it will be a raw vector with a "content-type" attribute (if specified in the headers) */

static SEXP parse_request_body(httpd_conn_t *c) {

    if (!c || !c->body) return R_NilValue;

    if (c->attr & CONTENT_FORM_UENC) { /* URL encoded form - return parsed form */

	c->body[c->content_length] = 0; /* the body is guaranteed to have an extra byte for the termination */

	return parse_query(c->body);

    } else { /* something else - pass it as a raw vector */

	SEXP res = PROTECT(Rf_allocVector(RAWSXP, c->content_length));

	if (c->content_length)

	    memcpy(RAW(res), c->body, c->content_length);

	if (c->content_type) { /* attach the content type so it can be interpreted */

	    if (!R_ContentTypeName) R_ContentTypeName = install("content-type");

	    setAttrib(res, R_ContentTypeName, mkString(c->content_type));

	}

	UNPROTECT(1);

	return res;

    }

}

#ifdef _WIN32

/* on Windows we have to guarantee that process_request is performed

 * on the main thread, so we have to dispatch it through a message */

static void process_request_main_thread(httpd_conn_t *c);

static void process_request(httpd_conn_t *c)

{

    if (WaitForSingleObject(process_request_mutex, INFINITE) != 0) {

	DBG(printf("Acquiring mutex failed\n"));

        /* (very) unexpected error, maybe we're shutting down? */

        return;

    }

    /* SendMessage is synchronous, so it will wait until the message

     * is processed */

    DBG(printf("enqueuing process_request_main_thread\n"));

    SendMessage(message_window, WM_RHTTP_CALLBACK, 0, (LPARAM) c);

    DBG(printf("process_request_main_thread returned\n"));

    ReleaseMutex(process_request_mutex);

}

#define process_request process_request_main_thread

#endif

/* finalize a request - essentially for HTTP/1.0 it means that

 * we have to close the connection */

static void fin_request(httpd_conn_t *c) {

    if (!IS_HTTP_1_1(c))

	c->attr |= CONNECTION_CLOSE;

}

static SEXP custom_handlers_env;

/* returns a httpd handler (closure) for a given path. As a special case

 * it can return a symbol that will be resolved in the "tools" namespace.

 * currently it allows custom handlers for paths of the form

 * /custom/<name>[/.*] where <name> must less than 64 characters long

 * and is matched against closures in tools:::.httpd.handlers.env */

static SEXP handler_for_path(const char *path) {

    if (path && !strncmp(path, "/custom/", 8)) { /* starts with /custom/ ? */

	const char *c = path + 8, *e = c;

	while (*c && *c != '/') c++; /* find out the name */

	if (c - e > 0 && c - e < 64) { /* if it's 1..63 chars long, proceed */

	    char fn[64];

	    memcpy(fn, e, c - e); /* create a local C string with the name for the install() call */

	    fn[c - e] = 0;

	    DBG(printf("handler_for_path('%s'): looking up custom handler '%s'\n", path, fn));

	    /* we cache custom_handlers_env so in case it has not been loaded yet, fetch it */

	    if (!custom_handlers_env) {

		if (!R_HandlersName) R_HandlersName = install(".httpd.handlers.env");

		SEXP toolsNS = PROTECT(R_FindNamespace(mkString("tools")));

		custom_handlers_env = eval(R_HandlersName, toolsNS);

		UNPROTECT(1); /* toolsNS */

	    }

	    /* we only proceed if .httpd.handlers.env really exists */

	    if (TYPEOF(custom_handlers_env) == ENVSXP) {

		SEXP cl = findVarInFrame(custom_handlers_env, install(fn));

		if (cl != R_UnboundValue && TYPEOF(cl) == CLOSXP) /* we need a closure */

		    return cl;

	    }

	}

    }

    DBG(printf(" - falling back to default httpd\n"));

    return install("httpd");

}

/* process a request by calling the httpd() function in R */

static void process_request_(void *ptr)

{

    httpd_conn_t *c = (httpd_conn_t*) ptr;

    const char *ct = "text/html";

    char *query = 0, *s;

    SEXP sHeaders = R_NilValue;

    int code = 200;

    const void *vmax = NULL;

    DBG(printf("process request for %p\n", (void*) c));

    if (!c || !c->url) return; /* if there is not enough to process, bail out */

    vmax = vmaxget();

    s = c->url;

    while (*s && *s != '?') s++; /* find the query part */

    if (*s) {

	*(s++) = 0;

	query = s;

    }

    uri_decode(c->url); /* decode the path part */

    {   /* construct "try(httpd(url, query, body), silent=TRUE)" */

	SEXP sTrue = PROTECT(ScalarLogical(TRUE));

	SEXP sBody = PROTECT(parse_request_body(c));

	SEXP sQuery = PROTECT(query ? parse_query(query) : R_NilValue);

	SEXP sReqHeaders = PROTECT(c->headers ? collect_buffers(c->headers) : R_NilValue);

	SEXP sArgs = PROTECT(list4(mkString(c->url), sQuery, sBody, sReqHeaders));

	SEXP sTry = install("try");

	SEXP y, x = PROTECT(lang3(sTry,

				  LCONS(handler_for_path(c->url), sArgs),

				  sTrue));

	SET_TAG(CDR(CDR(x)), install("silent"));

	DBG(printf("eval(try(httpd('%s'),silent=TRUE))\n", c->url));

	/* evaluate the above in the tools namespace */

	SEXP toolsNS = PROTECT(R_FindNamespace(mkString("tools")));

	x = eval(x, toolsNS);

	UNPROTECT(1); /* toolsNS */

	PROTECT(x);

	/* the result is expected to have one of the following forms:

	  a) character vector of length 1 => error (possibly from try),

	     will create 500 response

	      the string must specify charset UTF-8 and the server will

	      convert it to UTF-8 (must be in sync with dynamicHelp.R)

	  b) list(payload[, content-type[, headers[, status code]]])

	      payload: can be a character vector of length one or a

	      raw vector. if the character vector is named "file" then

	      the content of a file of that name is the payload (the file

	      will be served byte-by-byte and the headers must specify

	      the charset of the file). if the character vector is not named

	      "file", it will be converted to UTF-8 (and hence the vector

	      itself must specify charset UTF-8, must be in sync with

	      dynamicHelp.R)

	      content-type: must be a character vector of length one

	      or NULL (if present, else default is "text/html")

	      headers: must be a character vector - the elements will

	      have CRLF appended and neither Content-type nor

	      Content-length may be used

	     status code: must be an integer if present (default is 200)

	 */

	if (TYPEOF(x) == STRSXP && LENGTH(x) > 0) { /* string means there was an error */

	    const char *s = translateCharUTF8(STRING_ELT(x, 0));

	    send_http_response(c, " 500 Evaluation error\r\nConnection: close\r\nContent-type: text/plain\r\n\r\n");

	    DBG(printf("respond with 500 and content: %s\n", translateChar(STRING_ELT(x, 0))));

	    if (c->method != METHOD_HEAD)

		send_response(c->sock, s, strlen(s));

	    c->attr |= CONNECTION_CLOSE; /* force close */

	    UNPROTECT(7);

	    vmaxset(vmax);

	    return;

	}

	if (TYPEOF(x) == VECSXP && LENGTH(x) > 0) { /* a list (generic vector) can be a real payload */

	    SEXP xNames = getAttrib(x, R_NamesSymbol);

	    if (LENGTH(x) > 1) {

		SEXP sCT = VECTOR_ELT(x, 1); /* second element is content type if present */

		if (TYPEOF(sCT) == STRSXP && LENGTH(sCT) > 0)

		    ct = translateCharUTF8(STRING_ELT(sCT, 0));

		if (LENGTH(x) > 2) { /* third element is headers vector */

		    sHeaders = VECTOR_ELT(x, 2);

		    if (TYPEOF(sHeaders) != STRSXP)

			sHeaders = R_NilValue;

		    if (LENGTH(x) > 3) /* fourth element is HTTP code */

			code = asInteger(VECTOR_ELT(x, 3));

		}

	    }

	    y = VECTOR_ELT(x, 0);

	    if (TYPEOF(y) == STRSXP && LENGTH(y) > 0) {

		char buf[64];

		const char *cs = translateCharUTF8(STRING_ELT(y, 0)), *fn = 0;

		if (code == 200)

		    send_http_response(c, " 200 OK\r\nContent-type: ");

		else {

		    snprintf(buf, 64, "%s %d Code %d\r\nContent-type: ",

			     HTTP_SIG(c), code, code);

		    send_response(c->sock, buf, strlen(buf));

		}

		send_response(c->sock, ct, strlen(ct));

		if (sHeaders != R_NilValue) {

		    unsigned int i = 0, n = LENGTH(sHeaders);

		    for (; i < n; i++) {

			const char *hs = translateCharUTF8(STRING_ELT(sHeaders, i));

			send_response(c->sock, "\r\n", 2);

			send_response(c->sock, hs, strlen(hs));

		    }

		}

		/* special content - a file: either list(file="") or list(c("*FILE*", "")) - the latter will go away */

		if (TYPEOF(xNames) == STRSXP && LENGTH(xNames) > 0 &&

		    !strcmp(translateChar(STRING_ELT(xNames, 0)), "file"))

		    fn = translateChar(STRING_ELT(y, 0)); /* translateCharFP2 not exported */

		if (LENGTH(y) > 1 && !strcmp(cs, "*FILE*"))

		    fn = translateChar(STRING_ELT(y, 1)); /* translateCharFP2 not exported */

		if (fn) {

		    char *fbuf;

		    FILE *f = fopen(fn, "rb");

		    long fsz = 0;

		    if (!f) {

			send_response(c->sock, "\r\nContent-length: 0\r\n\r\n", 23);

			UNPROTECT(7);

			fin_request(c);

			vmaxset(vmax);

			return;

		    }

		    fseek(f, 0, SEEK_END);

		    fsz = ftell(f);

		    fseek(f, 0, SEEK_SET);

		    snprintf(buf, 64, "\r\nContent-length: %ld\r\n\r\n", fsz);

		    send_response(c->sock, buf, strlen(buf));

		    if (c->method != METHOD_HEAD) {

			fbuf = (char*) malloc(32768);

			if (fbuf) {

			    while (fsz > 0 && !feof(f)) {

				size_t rd = (fsz > 32768) ? 32768 : fsz;

				if (fread(fbuf, 1, rd, f) != rd) {

				    free(fbuf);

				    UNPROTECT(7);

				    c->attr |= CONNECTION_CLOSE;

				    fclose(f);

				    vmaxset(vmax);

				    return;

				}

				send_response(c->sock, fbuf, rd);

				fsz -= rd;

			    }

			    free(fbuf);

			} else { /* allocation error - get out */

			    UNPROTECT(7);

			    c->attr |= CONNECTION_CLOSE;

			    fclose(f);

			    vmaxset(vmax);

			    return;

			}

		    }

		    fclose(f);

		    UNPROTECT(7);

		    fin_request(c);

		    vmaxset(vmax);

		    return;

		}

		snprintf(buf, 64, "\r\nContent-length: %u\r\n\r\n",

			 (unsigned int) strlen(cs));

		send_response(c->sock, buf, strlen(buf));

		if (c->method != METHOD_HEAD)

		    send_response(c->sock, cs, strlen(cs));

		UNPROTECT(7);

		fin_request(c);

		vmaxset(vmax);

		return;

	    }

	    if (TYPEOF(y) == RAWSXP) {

		char buf[64];

		Rbyte *cs = RAW(y);

		if (code == 200)

		    send_http_response(c, " 200 OK\r\nContent-type: ");

		else {

		    snprintf(buf, 64, "%s %d Code %d\r\nContent-type: ",

			     HTTP_SIG(c), code, code);

		    send_response(c->sock, buf, strlen(buf));

		}

		send_response(c->sock, ct, strlen(ct));

		if (sHeaders != R_NilValue) {

		    unsigned int i = 0, n = LENGTH(sHeaders);

		    for (; i < n; i++) {

			const char *hs = translateCharUTF8(STRING_ELT(sHeaders, i));

			send_response(c->sock, "\r\n", 2);

			send_response(c->sock, hs, strlen(hs));

		    }

		}

		snprintf(buf, 64, "\r\nContent-length: %u\r\n\r\n", LENGTH(y));

		send_response(c->sock, buf, strlen(buf));

		if (c->method != METHOD_HEAD)

		    send_response(c->sock, (char*) cs, LENGTH(y));

		UNPROTECT(7);

		fin_request(c);

		vmaxset(vmax);

		return;

	    }

	}

	UNPROTECT(7);

    }

    send_http_response(c, " 500 Invalid response from R\r\nConnection: close\r\nContent-type: text/plain\r\n\r\nServer error: invalid response from R\r\n");

    c->attr |= CONNECTION_CLOSE; /* force close */

    vmaxset(vmax);

}

/* wrap the actual call with ToplevelExec since we need to have a guaranteed

   return so we can track the presence of a worker code inside R to prevent

   re-entrance from other clients

   on Windows, this function is named process_request_main_thread via

   C preprocessor; on all platforms it is executed on the main R thread

*/

static void process_request(httpd_conn_t *c)

{

#ifndef _WIN32

    in_process = 1;

#endif

    R_ToplevelExec(process_request_, c);

#ifndef _WIN32

    in_process = 0;

#endif

}

#ifdef _WIN32

#undef process_request

#endif

/* Remove . and (most) .. from "p" following RFC 3986, 5.2.4.*/

static char *remove_dot_segments(char *p) {

    char *inbuf = Rstrdup(p);

    char *in = inbuf;   /* first byte of input buffer */

    char *outbuf = malloc(strlen(inbuf) + 1);

    if (!outbuf)

	error("allocation error in remove_dot_segments");

    char *out = outbuf; /* last byte (terminator) of output buffer */

    *out = '\0';

    while(*in) {

/*

       A.  If the input buffer begins with a prefix of "../" or "./",

           then remove that prefix from the input buffer; otherwise,

*/

	if (in[0] == '.' && in[1] == '.' && in[2] == '/') {

	    /* remove "../" */

	    in += 3;

	    continue;

	}

	if (in[0] == '.' && in[1] == '/') {

	    /* remove "./" */

	    in += 2;

	    continue;

	}

/*

       B.  if the input buffer begins with a prefix of "/./" or "/.",

           where "." is a complete path segment, then replace that

           prefix with "/" in the input buffer; otherwise,

*/

	if (in[0] == '/' && in[1] == '.' && in[2] == '/') {

	    /* replace "/./" by "/"  */

	    in += 2;

	    continue;

	}

	if (in[0] == '/' && in[1] == '.' && in[2] == '\0') {

	    /* replace trailing "/." by "/"  */

	    in[1] = '\0';

	    continue;

	}

/*

       C.  if the input buffer begins with a prefix of "/../" or "/..",

           where ".." is a complete path segment, then replace that

           prefix with "/" in the input buffer and remove the last

           segment and its preceding "/" (if any) from the output

           buffer; otherwise,

*/

	if (in[0] == '/' && in[1] == '.' && in[2] == '.' && in[3] == '/') {

	    /* replace "/../" by "/" */

	    in += 3;

	    /* remove trailing "/segment" from output */

	    while(out > outbuf && *out != '/') out--;

	    *out = '\0';

	    continue;

	}

	if (in[0] == '/' && in[1] == '.' && in[2] == '.' && in[3] == '\0') {

	    /* replace trailing "/.." by "/" */

	    in[1] = '\0';

	    /* remove trailing "/segment" from output */

	    while(out > outbuf && *out != '/') out--;

	    *out = '\0';

	    continue;

	}

/*

       D.  if the input buffer consists only of "." or "..", then remove

           that from the input buffer; otherwise,

*/

	if ( (in[0] == '.' && in[1] == '\0') ||

	     (in[0] == '.' && in[1] == '.' && in[2] == '\0') ) {

	    /* remove input */

	    in[0] = '\0';

	    continue;

	}

/*

       E.  move the first path segment in the input buffer to the end of

           the output buffer, including the initial "/" character (if

           any) and any subsequent characters up to, but not including,

           the next "/" character or the end of the input buffer.

*/

	if (in[0] == '/') {

	    *out++ = '/';

	    in++;

	}

	for(; *in && *in != '/'; in++) *out++ = *in;

	*out = '\0';

    }

    free(inbuf);

    return outbuf;

}

/* this function is called to fetch new data from the client

 * connection socket and process it */

static void worker_input_handler(void *data) {

    httpd_conn_t *c = (httpd_conn_t*) data;

    DBG(printf("worker_input_handler, data=%p\n", data));

    if (!c) return;

#ifndef _WIN32

    if (in_process) return; /* we don't allow recursive entrance */

#endif

    DBG(printf("input handler for worker %p (sock=%d, part=%d, method=%d, line_pos=%d)\n", (void*) c, (int)c->sock, (int)c->part, (int)c->method, (int)c->line_pos));

    /* FIXME: there is one edge case that is not caught on unix: if

     * recv reads two or more full requests into the line buffer then

     * this function exits after the first one, but input handlers may

     * not trigger, because there may be no further data. It is not

     * trivial to fix, because just checking for a full line at the

     * beginning and not calling recv won't trigger a new input

     * handler. However, under normal circumstance this should not

     * happen, because clients should wait for the response and even

     * if they don't it's unlikely that both requests get combined

     * into one packet. */

    if (c->part < PART_BODY) {

	char *s = c->line_buf;

	ssize_t n = recv(c->sock, c->line_buf + c->line_pos, 

			 LINE_BUF_SIZE - c->line_pos - 1, 0);

	DBG(printf("[recv n=%lld, line_pos=%llu, part=%d]\n", (long long)n,

	           (unsigned long long)c->line_pos, (int)c->part));

	if (n < 0) { /* error, scrape this worker */

	    remove_worker(c);

	    return;

	}

	if (n == 0) { /* connection closed -> try to process and then remove */

	    process_request(c);

	    remove_worker(c);

	    return;

	}

	c->line_pos += n;

	c->line_buf[c->line_pos] = 0;

	DBG(printf("in buffer: {%s}\n", c->line_buf));

	while (*s) {

	    /* ok, we have genuine data in the line buffer */

	    if (s[0] == '\n' || (s[0] == '\r' && s[1] == '\n')) { /* single, empty line - end of headers */

		/* --- check request validity --- */

		DBG(printf(" end of request, moving to body\n"));

		if (!(c->attr & HTTP_1_0) && !(c->attr & HOST_HEADER)) { /* HTTP/1.1 mandates Host: header */

		    send_http_response(c, " 400 Bad Request (Host: missing)\r\nConnection: close\r\n\r\n");

		    remove_worker(c);

		    return;

		}

		if (c->attr & CONTENT_LENGTH && c->content_length) {

		    if (c->content_length < 0 ||  /* we are parsing signed so negative numbers are bad */

			c->content_length > 2147483640 || /* R will currently have issues with body around 2Gb or more, so better to not go there */

			!(c->body = (char*) malloc(c->content_length + 1 /* allocate an extra termination byte */ ))) {

			send_http_response(c, " 413 Request Entity Too Large (request body too big)\r\nConnection: close\r\n\r\n");

			remove_worker(c);

			return;

		    }

		}

		c->body_pos = 0;

		c->part = PART_BODY;

		if (s[0] == '\r') s++;

		s++;

		/* move the body part to the beginning of the buffer */

		c->line_pos -= s - c->line_buf;

		memmove(c->line_buf, s, c->line_pos);

		/* GET/HEAD or no content length mean no body */

		if (c->method == METHOD_GET || c->method == METHOD_HEAD ||

		    !(c->attr & CONTENT_LENGTH) || c->content_length == 0) {

		    if ((c->attr & CONTENT_LENGTH) && c->content_length > 0) {