The R Project SVN R

/*

 *  R : A Computer Language for Statistical Data Analysis

 *  Copyright (C) 2009-2015 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. */

/* 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 orignally 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 <windows.h>

# include <winsock.h>

# include <string.h>

# define sockerrno WSAGetLastError()

# define ECONNREFUSED WSAECONNREFUSED

# define EADDRINUSE WSAEADDRINUSE

# define ENOTSOCK WSAENOTSOCK

# define EISCONN WSAEISCONN

# define ETIMEDOUT WSAETIMEDOUT

# define ENETUNREACH WSAENETUNREACH

# define EINPROGRESS WSAEINPROGRESS

# define EALREADY WSAEALREADY

# define EAFNOSUPPORT WSAEAFNOSUPPORT

# define EOPNOTSUPP WSAEOPNOTSUPP

# define EWOULDBLOCK WSAEWOULDBLOCK

/* those are occasionally defined by MinGW's errno, so override them

 * with socket equivalents */

# ifdef EBADF

#  undef EBADF

# endif

# ifdef EINVAL

#  undef EINVAL

# endif

# ifdef EFAULT

#  undef EFAULT

# endif

# ifdef EACCES

#  undef EACCES

# endif

# define EFAULT WSAEFAULT

# define EINVAL WSAEINVAL

# define EACCES WSAEACCES

# define EBADF WSAEBADF

static int initsocks(void)

{

    WSADATA dt;

    /* initialize WinSock 1.1 */

    return (WSAStartup(0x0101, &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];

};

/* we 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 */

static int in_process;

/* --- 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()

{

    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);

#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) {

	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=0x%x)\n", (void*) c, i, (int) 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)

{

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

     * is processed */

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

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

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

}

#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(Rprintf("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 = findVarInFrame3(custom_handlers_env, install(fn), TRUE);

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

		    return cl;

	    }

	}

    }

    DBG(Rprintf(" - 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;

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

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

    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(Rprintf("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

	  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

	      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 = CHAR(STRING_ELT(x, 0));

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

	    DBG(Rprintf("respond with 500 and content: %s\n", s));

	    if (c->method != METHOD_HEAD)

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

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

	    UNPROTECT(7);

	    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 = CHAR(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 = CHAR(STRING_ELT(y, 0)), *fn = 0;

		if (code == 200)

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

		else {

		    sprintf(buf, "%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 = CHAR(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(CHAR(STRING_ELT(xNames, 0)), "file"))

		    fn = cs;

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

		    fn = CHAR(STRING_ELT(y, 1));

		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);

			return;

		    }

		    fseek(f, 0, SEEK_END);

		    fsz = ftell(f);

		    fseek(f, 0, SEEK_SET);

		    sprintf(buf, "\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);

				    return;

				}

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

				fsz -= rd;

			    }

			    free(fbuf);

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

			    UNPROTECT(7);

			    c->attr |= CONNECTION_CLOSE;

			    fclose(f);

			    return;

			}

		    }

		    fclose(f);

		    UNPROTECT(7);

		    fin_request(c);

		    return;

		}

		sprintf(buf, "\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);

		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 {

		    sprintf(buf, "%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 = CHAR(STRING_ELT(sHeaders, i));

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

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

		    }

		}

		sprintf(buf, "\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);

		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 */

}

/* 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 */

static void process_request(httpd_conn_t *c)

{

    in_process = 1;

    R_ToplevelExec(process_request_, c);

    in_process = 0;

}

#ifdef _WIN32

#undef process_request

#endif

/* 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;

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

    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=%d, line_pos=%d, part=%d]\n", n, 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) {

			send_http_response(c, " 400 Bad Request (GET/HEAD with body)\r\n\r\n");

			remove_worker(c);

			return;

		    }

		    process_request(c);

		    if (c->attr & CONNECTION_CLOSE) {

			remove_worker(c);

			return;

		    }

		    /* keep-alive - reset the worker so it can process a new request */

		    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; }

		    c->body_pos = 0;

		    c->method = 0;

		    c->part = PART_REQUEST;

		    c->attr = 0;

		    c->content_length = 0;

		    return;

		}

		/* copy body content (as far as available) */

		c->body_pos = (c->content_length < c->line_pos) ? c->content_length : c->line_pos;

		if (c->body_pos) {

		    memcpy(c->body, c->line_buf, c->body_pos);

		    c->line_pos -= c->body_pos; /* NOTE: we are NOT moving the buffer since non-zero left-over causes connection close */

		}

		/* POST will continue into the BODY part */

		break;

	    }

	    {

		char *bol = s;

		while (*s && *s != '\r' && *s != '\n') s++;

		if (!*s) { /* incomplete line */

		    if (bol == c->line_buf) {

			if (c->line_pos < LINE_BUF_SIZE) /* one, incomplete line, but the buffer is not full yet, just return */

			    return;

			/* the buffer is full yet the line is incomplete - we're in trouble */

			send_http_response(c, " 413 Request entity too large\r\nConnection: close\r\n\r\n");

			remove_worker(c);

			return;

		    }

		    /* move the line to the begining of the buffer for later requests */

		    c->line_pos -= bol - c->line_buf;

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

		    return;

		} else { /* complete line, great! */

		    if (*s == '\r') *(s++) = 0;

		    if (*s == '\n') *(s++) = 0;

		    DBG(printf("complete line: {%s}\n", bol));

		    if (c->part == PART_REQUEST) {

			/* --- process request line --- */

			size_t rll = strlen(bol); /* request line length */

			char *url = strchr(bol, ' ');

			if (!url || rll < 14 || strncmp(bol + rll - 9, " HTTP/1.", 8)) { /* each request must have at least 14 characters [GET / HTTP/1.0] and have HTTP/1.x */

			    send_response(c->sock, "HTTP/1.0 400 Bad Request\r\n\r\n", 28);

			    remove_worker(c);

			    return;

			}

			url++;

			if (!strncmp(bol + rll - 3, "1.0", 3)) c->attr |= HTTP_1_0;

			if (!strncmp(bol, "GET ", 4)) c->method = METHOD_GET;

			if (!strncmp(bol, "POST ", 5)) c->method = METHOD_POST;

			if (!strncmp(bol, "HEAD ", 5)) c->method = METHOD_HEAD;

			/* only custom handlers can use other methods */

			if (!strncmp(url, "/custom/", 8)) {

			    char *mend = url - 1;

			    /* we generate a header with the method so it can be passed to the handler */

			    if (!c->headers)

				c->headers = alloc_buffer(1024, NULL);

			    /* make sure it fits */

			    if (c->headers->size - c->headers->length >= 18 + (mend - bol)) {

				if (!c->method) c->method = METHOD_OTHER;

				/* add "Request-Method: xxx" */

				memcpy(c->headers->data + c->headers->length, "Request-Method: ", 16);

				c->headers->length += 16;

				memcpy(c->headers->data + c->headers->length, bol, mend - bol);

				c->headers->length += mend - bol;	

				c->headers->data[c->headers->length++] = '\n';

			    }

			}

			if (!c->method) {

			    send_http_response(c, " 501 Invalid or unimplemented method\r\n\r\n");

			    remove_worker(c);

			    return;

			}

			bol[strlen(bol) - 9] = 0;

			c->url = strdup(url);

			c->part = PART_HEADER;

			DBG(printf("parsed request, method=%d, URL='%s'\n", (int)c->method, c->url));

		    } else if (c->part == PART_HEADER) {

			/* --- process headers --- */

			char *k = bol;

			if (!c->headers)

			    c->headers = alloc_buffer(1024, NULL);

			if (c->headers) { /* record the header line in the buffer */

			    size_t l = strlen(bol);

			    if (l) { /* this should be really always true */

				if (c->headers->length + l + 1 > c->headers->size) { /* not enough space? */

				    size_t fits = c->headers->size - c->headers->length;

				    if (fits) memcpy(c->headers->data + c->headers->length, bol, fits);

				    if (alloc_buffer(2048, c->headers)) {

					c->headers = c->headers->next;

					memcpy(c->headers->data, bol + fits, l - fits);

					c->headers->length = l - fits;

					c->headers->data[c->headers->length++] = '\n';

				    }

				} else {

				    memcpy(c->headers->data + c->headers->length, bol, l);

				    c->headers->length += l;	

				    c->headers->data[c->headers->length++] = '\n';

				}

			    }

			}

			while (*k && *k != ':') {

			    if (*k >= 'A' && *k <= 'Z')

				*k |= 0x20;

			    k++;

			}

			if (*k == ':') {

			    *(k++) = 0;

			    while (*k == ' ' || *k == '\t') k++;

			    DBG(printf("header '%s' => '%s'\n", bol, k));

			    if (!strcmp(bol, "content-length")) {

				c->attr |= CONTENT_LENGTH;

				c->content_length = atol(k);

			    }

			    if (!strcmp(bol, "content-type")) {

				char *l = k;

				/* convert content-type to lowercase to facilitate comparison

				   since MIME types are case-insensitive.

				   However, we have to stop at ; since parameters

				   may be case-sensitive (see PR 16541) */

				while (*l && *l != ';') { if (*l >= 'A' && *l <= 'Z') *l |= 0x20; l++; }

				c->attr |= CONTENT_TYPE;

				if (c->content_type) free(c->content_type);

				c->content_type = strdup(k);