/*
 * tnmHttp.c --
 *
 *	This file contains an implementation of the HTTP/1.0 http protocol.
 *	Note, it does not implement the LINK and UNLINK methods, which are
 *	part of HTTP/1.0.
 *
 * Copyright (c) 1994-1996 Technical University of Braunschweig.
 * Copyright (c) 1996-1997 University of Twente.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tnmInt.h"
#include "tnmPort.h"

/*
 * Still left to do:
 *
 * - Implement an asynchronous interface.
 *
 * - Handle errors where objects have moved internally.
 *
 * - Bindings should be sorted to allow specific bindings to match
 *   always before specific bindings. An example:
 *
 *   http bind /AA get {}
 *   http bind /A* get {}
 *
 *   In this case, the second rule fires which is perhaps not what
 *   we want. However, it is not easy to determine the most general
 *   binding. Ideas welcome.
 *
 * - RFC 1521 base64 encodings (during server processing)
 * - More %-escapes: 
 *   %V Arguments split using the URL argument rules.
 *   %W The password of the user.
 *   %U The user name.
 */

static char *proxy = NULL;
static int proxyport = 80;
static char *httpVersion = "HTTP/1.0";

#define HTTP_OK			200
#define HTTP_CREATED		201
#define HTTP_ACCEPTED		202
#define HTTP_PARTIAL		203
#define HTTP_NORESPONSE		204
#define HTTP_DELETED		205
#define HTTP_MODIFIED		206
#define HTTP_MOVED		301
#define HTTP_FOUND		302
#define HTTP_METHOD		303
#define HTTP_NOTMODIFIED	304
#define HTTP_BADREQUEST		400
#define HTTP_UNAUTH		401
#define HTTP_PAYFORIT		402
#define HTTP_FORBIDDEN		403
#define HTTP_NOTFOUND		404
#define HTTP_NOTALLOWED		405
#define HTTP_NONEACCEPTABLE	406
#define HTTP_PROXYAUTHREQUIRED	407
#define HTTP_REQUESTTIMEOUT	408
#define HTTP_INTERNAL		500
#define HTTP_NOTYET		501
#define HTTP_BADGATEWAY		502
#define HTTP_SERVICEUNAVAIL	503
#define HTTP_GATEWAYTIMEOUT	504

/*
 * Used to build a table of error codes and their readable 
 * error description (see below). This is based on the http
 * internet draft issued 19 December 1994.
 */

static TnmTable httpStatusTable[] = {
    { HTTP_OK,			"OK" },
    { HTTP_CREATED,		"Created" },
    { HTTP_ACCEPTED,		"Accepted" },
    { HTTP_PARTIAL,		"Provisional Information" },
    { HTTP_NORESPONSE,		"No Response" },
    { HTTP_DELETED,		"Deleted" },
    { HTTP_MODIFIED,		"Modified" },

    { HTTP_MOVED,		"Moved Permanently" },
    { HTTP_FOUND,		"Moved Temporarily" },
    { HTTP_METHOD,		"Method" },
    { HTTP_NOTMODIFIED,		"Not Modified" },

    { HTTP_BADREQUEST,		"Bad Request" },
    { HTTP_UNAUTH,		"Unauthorized" },
    { HTTP_PAYFORIT,		"Payment Required" },
    { HTTP_FORBIDDEN,		"Forbidden" },
    { HTTP_NOTFOUND,		"Not Found" },
    { HTTP_NOTALLOWED,		"Method Not Allowed" },
    { HTTP_NONEACCEPTABLE,	"None Acceptable" },
    { HTTP_PROXYAUTHREQUIRED,	"Proxy Authentication Required" },
    { HTTP_REQUESTTIMEOUT,	"Request Timeout" },

    { HTTP_INTERNAL,		"Internal Error" },
    { HTTP_NOTYET,		"Not Implemented" },
    { HTTP_BADGATEWAY,		"Bad Gateway" },
    { HTTP_SERVICEUNAVAIL,	"Service Unavailable" },
    { HTTP_GATEWAYTIMEOUT,	"Gateway Timeout" },

    { 0, NULL },
};

/*
 * The event types currently in use. More to come soon ;-)
 */

#define HTTP_GET_EVENT		1
#define HTTP_HEAD_EVENT		2
#define HTTP_POST_EVENT		3
#define HTTP_PUT_EVENT		4
#define HTTP_DELETE_EVENT	5
#define HTTP_LINK_EVENT		6
#define HTTP_UNLINK_EVENT	7

static TnmTable httpEvents[] = {
    { HTTP_GET_EVENT,		"get" },
    { HTTP_HEAD_EVENT,		"head" },
    { HTTP_POST_EVENT,		"post" },
    { HTTP_PUT_EVENT,		"put" },
    { HTTP_DELETE_EVENT,	"delete" },
    { HTTP_LINK_EVENT,		"link" },
    { HTTP_UNLINK_EVENT,	"unlink" },
    { 0,			NULL },
};

/*
 * A structure to hold a binding for a given URL.
 */

typedef struct HttpBinding {
    int eventType;			/* Event that triggers binding. */
    char *pattern;			/* URL pattern to match.	*/
    char *command;			/* Tcl command to evaluate.     */
    struct HttpBinding *nextPtr;	/* Next binding in our list.    */
} HttpBinding;

static HttpBinding *bindList = (HttpBinding *) NULL;

/*
 * The struct HttpUrl is used to represent a URL. 
 */

typedef struct HttpUrl {
    char *host;
    unsigned port;
    char *path;
    char *auth;
} HttpUrl;

/*
 * The following two hash tables are used to hold the content-type and
 * content-encoding mappings. They are indexed by file extensions.
 */

static Tcl_HashTable mimeTypeTable;

/*
 * Forward declarations for procedures defined later in this file:
 */

static char*
Base64Encode		_ANSI_ARGS_((char *string));

static char*
Base64Decode		_ANSI_ARGS_((char *string));

static int
HttpGetPort		_ANSI_ARGS_((char *name));

static HttpUrl*
HttpSplitUrl		_ANSI_ARGS_((char *str));

static void
HttpRequestLine		_ANSI_ARGS_((Tcl_Channel channel,
				     char *method, char *path));
static void
HttpStatusLine		_ANSI_ARGS_((Tcl_Channel channel, int code));

static void
HttpGeneralHeader	_ANSI_ARGS_((Tcl_Channel channel));

static void
HttpRequestHeader	_ANSI_ARGS_((Tcl_Channel channel, char *auth));

static void
HttpResponseHeader	_ANSI_ARGS_((Tcl_Channel channel));

static void
HttpObjectHeader	_ANSI_ARGS_((Tcl_Channel channel,
				     char *contentType, 
				     char *contentEncoding, 
				     int contentLength));
static void
HttpEndHeader		_ANSI_ARGS_((Tcl_Channel channel));

static void
HttpSendError		_ANSI_ARGS_((Tcl_Channel channel, int code));

static int
HttpSendObject		_ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel dst, 
				     Tcl_Channel src));
static int
HttpEvalCallback	_ANSI_ARGS_((Tcl_Interp *interp, char *callback,
				     char *addr, char *url));
static Tcl_Channel
HttpOpen		_ANSI_ARGS_((char *fileName, char **contentType, 
				     char **contentEncoding, 
				     int *contentLength));
static void
HttpAcceptProc		_ANSI_ARGS_((ClientData clientData, 
				     Tcl_Channel channel, 
				     char *hostName, int port));
static int
HttpRecvHeader		_ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel channel));

static int
HttpRecvBody		_ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel src,
				     Tcl_Channel dst));
static int
HttpProxy		_ANSI_ARGS_((Tcl_Interp *interp, 
				     int argc, char **argv));
static int
HttpHead		_ANSI_ARGS_((Tcl_Interp *interp, 
				     int argc, char **argv));
static int
HttpGet			_ANSI_ARGS_((Tcl_Interp *interp, 
				     int argc, char **argv));
static int
HttpPost		_ANSI_ARGS_((Tcl_Interp *interp, 
				     int argc, char **argv));
static int
HttpPut			_ANSI_ARGS_((Tcl_Interp *interp, 
				     int argc, char **argv));
static int
HttpDelete		_ANSI_ARGS_((Tcl_Interp *interp, 
				     int argc, char **argv));
static int
HttpServer		_ANSI_ARGS_((Tcl_Interp *interp, 
				     int argc, char **argv));
static int
HttpBind		_ANSI_ARGS_((Tcl_Interp *interp, 
				     int argc, char **argv));
static int
HttpMime		_ANSI_ARGS_((Tcl_Interp *interp, 
				     int argc, char **argv));
/*
 * The following defines are used to implement base64 en/decoding.
 * See RFC 1521 for a description of base64 en/decoding.
 */

#define valid(x) \
	((x >= 'A' && x <= 'Z') || (x >= 'a' && x <= 'z') || \
	 (x >= '0' && x <= '9') || x == '+' || x == '/')

#define val(x) \
	(x >= 'A' && x <= 'Z' ? x - 'A' : \
	 (x >= 'a' && x <= 'z' ? x - 'a' + 26 : \
	  (x >= '0' && x <= '9' ? x - '0' + 52 : \
	   (x == '+' ? 62 : (x == '/' ? 63 : 0)))))

#define lav(x) \
	(x <= 25 ? x + 'A' : \
	 (x >= 26 && x <= 51 ? x + 'a' - 26 : \
	  (x >= 52 && x <= 61 ? x + '0' - 52 : \
	   (x == 62 ? '+' : (x == 63 ? '/' : '?')))))


/*
 *----------------------------------------------------------------------
 *
 * Base64Encode --
 *
 *	This procedure encodes a string into a base64 encoded string.
 *
 * Results:
 *	A pointer to private buffer space holding the encoded value is 
 *	returned.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static char *
Base64Encode(in)
    char *in;
{
    static char *ret = NULL;
    static int size = 0;
    char *p;

    if ((strlen(in) + 4) * 2 >= size) {
	size = (strlen(in) + 4) * 2;
	if (ret) ckfree(ret);
	ret = ckalloc(size);
    }

    p = ret;

    for (;;) {
	unsigned char c[3];
	unsigned int d;
	int i, pad;

	if (! *in) break;

	i = 0, pad = -1;
	while (i < 3) {
	    if (*in) {
		c[i++] = *in++;
	    } else {
		c[i++] = 0, pad++;
	    }
	}
	  
	d = c[0] >> 2;
	*p++ = lav(d);

	if (pad < 2) {
	    d = ((c[0] & 0x3) << 4) | (c[1] >> 4);
	    *p++ = lav(d);
	} else {
	    *p++ = '=';
	}
	 
	if (pad < 1) {
	    d = ((c[1] & 0xf) << 2) | (c[2] >> 6);
	    *p++ = lav(d);
	} else {
	    *p++ = '=';
	}
	  
	if (pad < 0) {
	    d = c[2] & 0x3f;
	    *p++ = lav(d);
	} else  {
	    *p++ = '=';
	}
	  
	if (pad != -1) break;
    }

    *p = 0;
    
    return ret;
}

/*
 *----------------------------------------------------------------------
 *
 * Base64Decode --
 *
 *	This procedure decodes a base64 encoded string.
 *
 * Results:
 *	A pointer to private buffer space holding the result is returned.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static char *
Base64Decode(in)  
    char *in;
{
    static char *ret = NULL;
    static int size = 0;
    char *p;

    if ((strlen(in) + 4) * 2 >= size) {
	size = (strlen(in) + 4) * 2;
	if (ret) ckfree(ret);
	ret = ckalloc(size);
    }

    p = ret;

    for (;;) {
	int c[5];
	int i, d, pad;

	i = 0, pad = -1;
	while (i < 4) {
	    c[i] = *in++;
	    if (c[i] && valid(c[i])) {
		i++;
		continue;
	    }
	    if (c[i] && c[i] != '=') {
		continue;
	    }
	    while ((! c[i] || c[i] == '=') && i < 4) {
		pad++, c[i] = 0, i++, c[i] = '=';
	    }
	}
	  
	d = (val(c[0]) << 18) | 
	    (val(c[1]) << 12) | (val(c[2]) << 6) | val(c[3]);
	  
	if (pad < 2)
	  *p++ = (d & 0xff0000) >> 16;
	if (pad < 1)
	  *p++ = (d & 0xff00) >> 8;
	if (pad < 0)
	  *p++ = d & 0xff;
	
	if (c[4] == '=') {
	    *p = 0;
	    break;
	}
    }
    
    return ret;
}

/*
 *----------------------------------------------------------------------
 *
 * HttpGetPort --
 *
 *	This procedure is used to map a port number or name into a
 *	port number. According to the assigned numbers RFC, a service
 *	name may not start with a digit. So it should be save to look
 *	at the first byte to decide if its a service name or not.
 *
 * Results:
 *	A port number is returned. A negative value indicates that we
 *	can not resolve the given name.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
HttpGetPort(name)
    char *name;
{
    struct sockaddr_in addr;

    if (TnmSetIPPort(NULL, "tcp", name, &addr) != TCL_OK) {
	return -1;
    }
    return (int) ntohs(addr.sin_port);
}

/*
 *----------------------------------------------------------------------
 *
 * HttpSplitUrl --
 *
 *	This procedure splits a given URL into various parts according 
 *	to RFC 1738. This functions returns a pointer into private 
 *	memory. The caller must make a copy if there might be other
 *	calls to this procedure.
 *
 * Results:
 *	A pointer to a static HttpUrl structure is returned.
 *      On error NULL is returned.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static HttpUrl*
HttpSplitUrl(str)
    char *str;
{
    static HttpUrl url = { 0, 0, 0, 0 };
    char *hbuf;
    char *p, *q, *r = NULL;

    if (url.auth) {
	ckfree(url.auth);
	url.auth = NULL;
    }
    if (url.host) {
	ckfree(url.host);
	url.host = NULL;
    }
    if (url.path) {
	ckfree(url.path);
	url.path = NULL;
    }

    if (proxy) {
	url.host = ckstrdup(proxy);
	url.port = proxyport;
	url.path = ckstrdup(str);
	return &url;
    }
    
    hbuf = ckstrdup(str);

    /*
     * Strip off the beginning and check if we have a trivial
     * path on the local host.
     */

    p = hbuf;
    if (strncmp(p, "http://", 7) == 0 || strncmp(p, "HTTP://", 7) == 0) {
	p += 7;
    } else if (strncmp(p, "//", 2) == 0) {
	p += 2;
    } else {
	url.path = ckstrdup(p);
    }

    if (url.path) {
	url.host = ckstrdup(Tcl_GetHostName());
	url.port = 80;
	ckfree(hbuf);
	return &url;
    }

    /*
     * Now we know that we start with at least a host name. First get
     * the path before we start to extract the various optional host
     * specific informations.
     */

    q = strchr(p, '/');
    if (!q) {
	url.path = ckstrdup("/");
    } else {
	url.path = ckstrdup(q);
	*q = '\0';
    }

    /*
     * Next, lets see if we have a user and password field.
     */

    q = strchr(p, '@');
    if (q) {
	r = p;
	*q = '\0';
	p = ++q;
    }

    q = strchr(p, ':');
    if (q) {
	*q = '\0';
	url.host = ckstrdup(p);
	if (1 != sscanf(++q, "%u%*s", &url.port)) {
	    return NULL;
	} 
	if (url.port >= 65536) {
	    return NULL;
	}
    } else {
	url.host = ckstrdup(p);
	url.port = 80;
    }

    /*
     * Split up the user and password fields if we have one.
     */

    if (r) {
	url.auth = ckstrdup(r);
    }

    ckfree(hbuf);
    return &url;
}

/*
 *----------------------------------------------------------------------
 *
 * HttpRequestLine --
 *
 *	Send a request using the given method and document path 
 *	to a HTTP server.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	A request line is written on the channel.
 *
 *----------------------------------------------------------------------
 */

static void
HttpRequestLine(channel, method, path)
    Tcl_Channel channel;
    char *method;
    char *path;
{
    Tcl_Write(channel, method, -1);
    Tcl_Write(channel, " ", 1);
    Tcl_Write(channel, path, -1);
    Tcl_Write(channel, " ", 1);
    Tcl_Write(channel, httpVersion, -1);
    Tcl_Write(channel, "\n", 1);
}

/*
 *----------------------------------------------------------------------
 *
 * HttpStatusLine --
 *
 *	Send a status line to a HTTP client.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	A status line is written on the channel.
 *
 *----------------------------------------------------------------------
 */

static void
HttpStatusLine(channel, code)
    Tcl_Channel channel;
    int code;
{
    char buffer[256], *status;

    status = TnmGetTableValue(httpStatusTable, code);
    if (status) {
	sprintf(buffer, "%s %d %s\n", httpVersion, code, status);
    } else {
	sprintf(buffer, "%s 500 Unknown Internal Error\n", httpVersion);
    }

    Tcl_Write(channel, buffer, -1);
}

/*
 *----------------------------------------------------------------------
 *
 * HttpGeneralHeader --
 *
 *	Send a the general header portion as defined in the HTTP
 *	standard.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The general header is written on the channel.
 *
 *----------------------------------------------------------------------
 */

static void
HttpGeneralHeader(channel)
    Tcl_Channel channel;
{
    static char *weekdays[] = {
	"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"
    };
    static char *months[] = {
	"Jan", "Feb", "Mar", "Apr", "May", "Jun",
	"Jul", "Aug", "Sep", "Oct", "Nov", "Dec"
    };
    char buffer[256];
    time_t clock = time(0);
    struct tm *tm = gmtime(&clock);

    sprintf(buffer, "Date: %s, %2d %s 19%2d %02d:%02d:%02d\n",
	    weekdays[tm->tm_wday], tm->tm_mday, 
	    months[tm->tm_mon], tm->tm_year,
	    tm->tm_hour, tm->tm_min, tm->tm_sec);
    Tcl_Write(channel, buffer, -1);
    Tcl_Write(channel, "MIME-Version: 1.0\n", 18);
}

/*
 *----------------------------------------------------------------------
 *
 * HttpRequestHeader --
 *
 *	Send a the request header to a HTTP server.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	A request header is written on the channel.
 *
 *----------------------------------------------------------------------
 */

static void
HttpRequestHeader(channel, auth)
    Tcl_Channel channel;
    char *auth;
{
    Tcl_Write(channel, "User-Agent: scotty/", 19);
    Tcl_Write(channel, TNM_VERSION, -1);
    Tcl_Write(channel, "\n", 1);
    if (auth) {
	char *base = Base64Encode(auth);
	Tcl_Write(channel, "Authorization: Basic ", 21);
	Tcl_Write(channel, base, -1);
	Tcl_Write(channel, "\n", 1);
    }    
    Tcl_Write(channel, "Accept: */*\n", 12);
    Tcl_Write(channel, "Accept-Encoding: \n", 18);
}

/*
 *----------------------------------------------------------------------
 *
 * HttpResponseHeader --
 *
 *	Send a response header to a HTTP client.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	A response header is written on the channel.
 *
 *----------------------------------------------------------------------
 */

static void
HttpResponseHeader(channel)
    Tcl_Channel channel;
{
    Tcl_Write(channel, "Server: scotty/", 15);
    Tcl_Write(channel, TNM_VERSION, -1);
    Tcl_Write(channel, "\n", 1);
}

/*
 *----------------------------------------------------------------------
 *
 * HttpObjectHeader --
 *
 *	Send an object header to a HTTP entity. This procedure is used
 *	by clients and servers when transmitting HTTP objects.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	An object header is written on the channel.
 *
 *----------------------------------------------------------------------
 */

static void
HttpObjectHeader(channel, contentType, contentEncoding, contentLength)
    Tcl_Channel channel;
    char *contentType;
    char *contentEncoding;
    int contentLength;
{
    char buffer[20];
    
    sprintf(buffer, "%d", contentLength);

    Tcl_Write(channel, "Content-Type: ", 14);
    Tcl_Write(channel, contentType, -1);
    Tcl_Write(channel, "\n", 1);
    if (contentEncoding) {
	Tcl_Write(channel, "Content-Encoding: ", 18);
	Tcl_Write(channel, contentEncoding, -1);
	Tcl_Write(channel, "\n", 1);
    }
    Tcl_Write(channel, "Content-Length: ", 16);
    Tcl_Write(channel, buffer, -1);
    Tcl_Write(channel, "\n", 1);
}

/*
 *----------------------------------------------------------------------
 *
 * HttpEndHeader --
 *
 *	Close the header portion. We simply have to output an
 *	empty line.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The end of the header is written on the channel.
 *
 *----------------------------------------------------------------------
 */

static void
HttpEndHeader(channel)
    Tcl_Channel channel;
{
    Tcl_Write(channel, "\n", 1);
    Tcl_Flush(channel);
}

/*
 *----------------------------------------------------------------------
 *
 * HttpSendError --
 *
 *	This procedure sends an HTTP error message on the channel.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	An error message is written on the channel.
 *
 *----------------------------------------------------------------------
 */

static void
HttpSendError(channel, code)
    Tcl_Channel channel;
    int code;
{
    Tcl_DString dst;
    char *msg, buf[80];

    Tcl_DStringInit(&dst);
    sprintf(buf, "HTTP status %d: ", code);
    Tcl_DStringAppend(&dst, buf, -1);
    msg = TnmGetTableValue(httpStatusTable, code);
    if (! msg) {
	msg = "(unknown error - please fix the implementation)";
    }
    Tcl_DStringAppend(&dst, msg, -1);

    HttpStatusLine(channel, code);
    HttpGeneralHeader(channel);
    HttpResponseHeader(channel);
    Tcl_Write(channel, "Content-Type: text/plain\n", 25);
    Tcl_Write(channel, "Content-Length: ", 16);
    sprintf(buf, "%d", Tcl_DStringLength(&dst));
    Tcl_Write(channel, buf, -1);
    Tcl_Write(channel, "\n\n", 2);
    Tcl_Write(channel, Tcl_DStringValue(&dst), Tcl_DStringLength(&dst));

    Tcl_DStringFree(&dst);
}

/*
 *----------------------------------------------------------------------
 *
 * HttpSendObject --
 *
 *	This procedure writes the object given by channel src to
 *	the destination given by channel dst.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	An object is read and written to the HTTP stream.
 *
 *----------------------------------------------------------------------
 */

static int
HttpSendObject(interp, dst, src)
    Tcl_Interp *interp;
    Tcl_Channel dst;
    Tcl_Channel src;
{
    char buffer[1024];
    int n;

    Tcl_SetChannelOption(NULL, src, "-translation", "binary");
    Tcl_SetChannelOption(NULL, dst, "-translation", "binary");

    while (! Tcl_Eof(src)) {
	n = Tcl_Read(src, buffer, sizeof(buffer));
	if (n < 0) {
	    Tcl_ResetResult(interp);
	    Tcl_AppendResult(interp, "error sending HTTP body: ",
			     Tcl_PosixError(interp), (char *) NULL);
	    return TCL_ERROR;
	}
	if (n > 0) {
	    Tcl_Write(dst, buffer, n);
	} 
   }
	
    Tcl_Close((Tcl_Interp *) NULL, src);
    Tcl_Flush(dst);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * HttpEvalCallback --
 *
 *	This procedure evaluates a Tcl callback script. The command 
 *	string is modified according to the % escapes before evaluation. 
 *	The list of supported escapes is %A = address, %P = path,
 *	%S = searchpart.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	A Tcl command is evaluated which may cause any side effects.
 *
 *----------------------------------------------------------------------
 */

static int
HttpEvalCallback(interp, callback, addr, path)
    Tcl_Interp *interp;
    char *callback;
    char *addr;
    char *path;
{
    char buf[20];
    int code;
    Tcl_DString tclCmd;
    char *startPtr, *scanPtr;
    char *url, *search = NULL;

    /*
     * Split the path into a url and a search part. Make our own copy
     * to save the original path.
     */

    url = ckstrdup(path);
    for (scanPtr = url; *scanPtr != '\0'; scanPtr++) {
	if (!search && (*scanPtr == '?')) {
	    *scanPtr = '\0';
	    search = ++scanPtr;
	}
    }

    Tcl_DStringInit(&tclCmd);
    startPtr = callback;
    for (scanPtr = startPtr; *scanPtr != '\0'; scanPtr++) {
	if (*scanPtr != '%') {
	    continue;
	}
	Tcl_DStringAppend(&tclCmd, startPtr, scanPtr - startPtr);
	scanPtr++;
	startPtr = scanPtr + 1;
	switch (*scanPtr) {
	  case 'A':
	    if (addr) {
		Tcl_DStringAppend(&tclCmd, addr, -1);
	    }
	    break;
	  case 'P':
	    Tcl_DStringAppend(&tclCmd, url, -1);
	    break;
	  case 'S':
	    if (search) {
		Tcl_DStringAppend(&tclCmd, search, -1);
	    }
	    break;
	  default:
	    sprintf(buf, "%%%c", *scanPtr);
	    Tcl_DStringAppend(&tclCmd, buf, -1);
	}
    }
    Tcl_DStringAppend(&tclCmd, startPtr, scanPtr - startPtr);

    /*
     * Now evaluate the callback function and issue a background
     * error if the callback fails for some reason. Return the
     * original error message and code to the caller.
     */
    
    Tcl_AllowExceptions(interp);
    code = Tcl_GlobalEval(interp, Tcl_DStringValue(&tclCmd));
    Tcl_DStringFree(&tclCmd);

    if (code == TCL_ERROR) {
	char *errorMsg = ckstrdup(interp->result);
	Tcl_AddErrorInfo(interp, "\n    (http callback)");
        Tcl_BackgroundError(interp);
	Tcl_SetResult(interp, errorMsg, TCL_DYNAMIC);
    }

    ckfree(url);
    
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * HttpOpen --
 *
 *	This procedure opens a local file that will be send as an
 *	HTTP object.
 *
 * Results:
 *	A Tcl channel is returned or a NULL pointer if the file 
 *	not be opened. The contentType, contentEncoding, contentLength
 *	arguments are modified.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Channel
HttpOpen(fileName, contentType, contentEncoding, contentLength)
    char *fileName;
    char **contentType;
    char **contentEncoding;
    int *contentLength;
{
    Tcl_Channel channel;
    struct stat st;
    char *dot = NULL;
    int n;

    channel = Tcl_OpenFileChannel(NULL, fileName, "r", 0644);
    if (channel == NULL) {
	return NULL;
    }

    if (stat(fileName, &st) < 0) {
        return NULL;
    }

    *contentEncoding = NULL;
    *contentType = NULL;
    *contentLength = (int) st.st_size;

    /*
     * Guess the content encoding and the content type. We only support
     * x-compress and x-gzip encoding. This is a quick hack.
     */
    
    for (n = strlen(fileName) - 1; n >= 0; n--) {
	if (fileName[n] == '.' && *contentEncoding == NULL) {
	    if (strcmp(fileName+n, ".gz") == 0) {
		*contentEncoding = "x-gzip";
		dot = fileName + n;
		*dot = '\0';
	    } else if (strcmp(fileName+n, ".Z") == 0) {
		*contentEncoding = "x-compress";
		dot = fileName + n;
                *dot = '\0';
	    }
	}
	if (fileName[n] == '.') {
	    Tcl_HashEntry *entryPtr;
	    entryPtr = Tcl_FindHashEntry(&mimeTypeTable, fileName+n+1);
	    if (entryPtr) {
		*contentType = (char *) Tcl_GetHashValue(entryPtr);
	    }
	    break;
	}
    }
    if (dot) {
	*dot = '.';
    }

    if (! *contentType) {
	*contentType = "text/plain";
    }

    return channel;
}

/*
 *----------------------------------------------------------------------
 *
 * HttpAcceptProc --
 *
 * 	This procedure is called from the event loop to accept a http
 *	request. We just read the first bytes send from the client to
 *	see what we are supposed to do.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static void
HttpAcceptProc(clientData, channel, hostName, port)
    ClientData clientData;
    Tcl_Channel channel;
    char *hostName; 
    int port;
{
    Tcl_Interp *interp = (Tcl_Interp *) clientData;
    HttpBinding *bindPtr;
    int eventType;
    int n, rc;
    char *method = NULL, *path = NULL, *version = NULL, *p;
    Tcl_DString dst;

    Tcl_DStringInit(&dst);

    Tcl_SetChannelOption(interp, channel, "-translation", "crlf");

    n = Tcl_Gets(channel, &dst);
    if (n <= 0) {
	goto done;
    }

    /* 
     * parse the request line - ugly and simple version
     */
    
    p = Tcl_DStringValue(&dst);
    while (*p) {
	
	while (*p && isspace(*p)) p++;
	for (method = p; *p && !isspace(*p); p++) ;
	if (*p) *p++ = '\0';
	
	while (*p && isspace(*p)) p++;
	for (path = p; *p && !isspace(*p); p++) ;
	if (*p) *p++ = '\0';
	
	while (*p && isspace(*p)) p++;
	for (version = p; *p && !isspace(*p); p++) ;
	if (*p) *p++ = '\0';
	
	while (*p && isspace(*p)) p++;
    }

    if (method == NULL || path == NULL) {
	HttpSendError(channel, HTTP_INTERNAL);
	goto done;
    }

    if (strcmp(method, "GET") == 0) {
        eventType = HTTP_GET_EVENT;
    } else if (strcmp(method, "HEAD") == 0) {
        eventType = HTTP_HEAD_EVENT;
    } else if (strcmp(method, "POST") == 0) {
        eventType = HTTP_POST_EVENT;
    } else if (strcmp(method, "PUT") == 0) {
        eventType = HTTP_PUT_EVENT;
    } else if (strcmp(method, "DELETE") == 0) {
        eventType = HTTP_DELETE_EVENT;
    } else {
	HttpSendError(channel, HTTP_NOTYET);
	goto done;
    }

    for (bindPtr = bindList; bindPtr; bindPtr = bindPtr->nextPtr) {
        if (eventType == bindPtr->eventType &&
	    Tcl_StringMatch(path, bindPtr->pattern)) break;
    }
    if (! bindPtr) {
        HttpSendError(channel, HTTP_NOTFOUND);
	goto done;
    }

    Tcl_SetChannelOption(interp, channel, "-blocking", "0");

    rc = HttpEvalCallback(interp, bindPtr->command, hostName, path);
    if (rc == TCL_OK) {
	char *contentType, *contentEncoding;
	int contentLength;
	Tcl_Channel obj = HttpOpen(interp->result, &contentType, 
				   &contentEncoding, &contentLength);
	if (obj) {
	    HttpStatusLine(channel, HTTP_OK);
	    HttpGeneralHeader(channel);
	    HttpResponseHeader(channel);
	    HttpObjectHeader(channel, contentType, 
			     contentEncoding, contentLength);
	    HttpEndHeader(channel);
	    HttpSendObject(interp, channel, obj);
	} else {
	    HttpSendError(channel, HTTP_INTERNAL);
	}
    } else {
	int code = TnmGetTableKey(httpStatusTable, interp->result);
	HttpSendError(channel, (code < 0) ? HTTP_INTERNAL : code);
    }
    
done:
    Tcl_DStringFree(&dst);
    Tcl_Close((Tcl_Interp *) NULL, channel);
}

/*
 *----------------------------------------------------------------------
 *
 * HttpRecvHeader --
 *
 * 	This procedure receives the header returned from an http 
 *	server.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
HttpRecvHeader(interp, channel)
    Tcl_Interp *interp;
    Tcl_Channel channel;
{
    char *p, *code, *st;
    int error, len, rc;
    Tcl_DString dst;

    Tcl_DStringInit(&dst);

    rc = Tcl_Gets(channel, &dst);
    if (rc < 0) {
	Tcl_SetResult(interp, "receiving header failed", TCL_STATIC);
	return TCL_ERROR;
    }
    
    len = Tcl_DStringLength(&dst);
    st = Tcl_DStringValue(&dst);
    while (len > 0 && isspace(st[len-1])) {
	len--;
    }
    Tcl_DStringSetLength(&dst, len);

    /*
     * Skip the server id.
     */

    p = Tcl_DStringValue(&dst);
    while (*p && !isspace(*p)) {
	p++;
    }
    while (*p && isspace(*p)) p++;

    /*
     * Extract the error code.
     */

    code = p;
    while (*p && isdigit(*p)) p++;
    *p++ = '\0';

    error = atoi(code);
    if (error != HTTP_OK) {
	char *status = TnmGetTableValue(httpStatusTable, error);
	if (status) {
	    Tcl_SetResult(interp, status, TCL_STATIC);
	    Tcl_DStringFree(&dst);
	    return TCL_ERROR;
	}
	Tcl_SetResult(interp, p, TCL_VOLATILE);
	Tcl_DStringFree(&dst);
	return TCL_ERROR;
    }

    while (1) {

	Tcl_DStringFree(&dst);
	rc = Tcl_Gets(channel, &dst);
	if (rc < 0) break;

	len = Tcl_DStringLength(&dst);
	st = Tcl_DStringValue(&dst);
	while (len > 0 && isspace(st[len-1])) {
	    len--;
	}
	Tcl_DStringSetLength(&dst, len);
	if (len == 0) {
	    return TCL_OK;
	}
	
	/*
         * Each header-line should have the form `text: value'.
         * Ignore everything that does not match this format.
         */
        
        p = Tcl_DStringValue(&dst);
        while (*p && *p != ':') p++;
        if (*p) {
            *p++ = '\0';
            Tcl_AppendElement(interp, Tcl_DStringValue(&dst));
            while (*p && isspace(*p)) p++;
            Tcl_AppendElement(interp, p);
        }
    }

    Tcl_DStringFree(&dst);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * HttpRecvBody --
 *
 * 	This procedure receives the body of a http message from src
 *	and writes it to dst.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
HttpRecvBody(interp, src, dst)
    Tcl_Interp *interp;
    Tcl_Channel src;
    Tcl_Channel dst;
{
    char buffer[1024];
    int n;

    Tcl_SetChannelOption(NULL, src, "-translation", "binary");
    Tcl_SetChannelOption(NULL, dst, "-translation", "binary");

    while (! Tcl_Eof(src)) {
	n = Tcl_Read(src, buffer, sizeof(buffer));
	if (n < 0) {
	    Tcl_ResetResult(interp);
	    Tcl_AppendResult(interp, "error reading HTTP body: ",
			     Tcl_PosixError(interp), (char *) NULL);
	    return TCL_ERROR;
	}
	if (n > 0) {
	    Tcl_Write(dst, buffer, n);
	}
    }
    
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * HttpProxy --
 *
 * 	This procedure sets the proxy host. A previously set proxy
 *	host will be removed if the argument to the proxy option
 *	is empty.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
HttpProxy(interp, argc, argv)
    Tcl_Interp *interp;
    int argc;
    char **argv;
{
    if (argc < 2 && argc > 3) {
	TnmWrongNumArgs(interp, 2, argv, "host");
	return TCL_ERROR;
    }
    
    if (argc == 3) {
	if (strlen(argv[2]) == 0) {
	    if (proxy) {
		ckfree(proxy);
		proxy = NULL;
		proxyport = 80;
	    }
	} else {
	    char *p = strchr(argv[2], ':');
	    if (p) {
		*p = '\0';
		if (Tcl_GetInt(interp, ++p, &proxyport) != TCL_OK)
			return TCL_ERROR;
		proxy = ckstrdup(argv[2]);
	    } else {
		proxy = ckstrdup(argv[2]);
		proxyport = 80;
	    }
	}
    }
    
    if (proxy) {
	Tcl_SetResult(interp, proxy, TCL_STATIC);
    }
    
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * HttpHead --
 *
 * 	This procedure implements the http head command as described
 *	in the user documentation.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
HttpHead(interp, argc, argv)
    Tcl_Interp *interp;
    int argc;
    char **argv;
{
    Tcl_Channel src;
    HttpUrl *url;
    int code;

    if (argc != 3) {
	TnmWrongNumArgs(interp, 2, argv, "url");
	return TCL_ERROR;
    }

    url = HttpSplitUrl(argv[2]);
    if (url == NULL) {
	Tcl_AppendResult(interp, "url syntax error", (char *) NULL);
	return TCL_ERROR;
    }
    src = Tcl_OpenTcpClient(interp, url->port, url->host, (char *) NULL, 0, 0);
    if (src == NULL) {
	return TCL_ERROR;
    }
    Tcl_SetChannelOption(interp, src, "-translation", "crlf");

    HttpRequestLine(src, "HEAD", url->path);
    HttpGeneralHeader(src);
    HttpRequestHeader(src, url->auth);
    HttpEndHeader(src);

    code = HttpRecvHeader(interp, src);
    Tcl_Close((Tcl_Interp *) NULL, src);
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * HttpGet --
 *
 * 	This procedure implements the http get command as described
 *	in the user documentation.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
HttpGet(interp, argc, argv)
    Tcl_Interp *interp;
    int argc;
    char **argv;
{
    Tcl_Channel src, dst;
    HttpUrl *url;
    int code;

    if (argc != 4) {
	TnmWrongNumArgs(interp, 2, argv, "url fileName");
	return TCL_ERROR;
    }

    dst = Tcl_OpenFileChannel(interp, argv[3], "w", 0644);
    if (dst == NULL) {
	return TCL_ERROR;
    }

    url = HttpSplitUrl(argv[2]);
    if (url == NULL) {
	Tcl_AppendResult(interp, "url syntax error", (char *) NULL);
	return TCL_ERROR;
    }
    src = Tcl_OpenTcpClient(interp, url->port, url->host, (char *) NULL, 0, 0);
    if (src == NULL) {
	Tcl_Close((Tcl_Interp *) NULL, dst);
	return TCL_ERROR;
    }
    Tcl_SetChannelOption(interp, src, "-translation", "crlf");

    HttpRequestLine(src, "GET", url->path);
    HttpGeneralHeader(src);
    HttpRequestHeader(src, url->auth);
    HttpEndHeader(src);
    
    code = HttpRecvHeader(interp, src);
    if (code == TCL_OK) {
	code = HttpRecvBody(interp, src, dst);
    }
    
    Tcl_Close((Tcl_Interp *) NULL, src);
    Tcl_Close((Tcl_Interp *) NULL, dst);
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * HttpPost --
 *
 * 	This procedure implements the http post command as described
 *	in the user documentation.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
HttpPost(interp, argc, argv)
    Tcl_Interp *interp;
    int argc;
    char **argv;
{
    Tcl_Channel src, dst, obj;
    HttpUrl *url;
    char *contentType, *contentEncoding;
    int code, contentLength;

    if (argc != 5) {
	TnmWrongNumArgs(interp, 2, argv, "url text fileName");
	return TCL_ERROR;
    }

    dst = Tcl_OpenFileChannel(interp, argv[3], "w", 0644);
    if (dst == NULL) {
	return TCL_ERROR;
    }

    url = HttpSplitUrl(argv[2]);
    if (url == NULL) {
	Tcl_AppendResult(interp, "url syntax error", (char *) NULL);
	return TCL_ERROR;
    }
    src = Tcl_OpenTcpClient(interp, url->port, url->host, (char *) NULL, 0, 0);
    if (src == NULL) {
	Tcl_Close((Tcl_Interp *) NULL, dst);
	return TCL_ERROR;
    }
    Tcl_SetChannelOption(interp, src, "-translation", "crlf");

    obj = HttpOpen(argv[3], &contentType, &contentEncoding, &contentLength);
    if (! obj) {
	Tcl_Close((Tcl_Interp *) NULL, src);
	Tcl_Close((Tcl_Interp *) NULL, dst);
        Tcl_AppendResult(interp, "can not read \"", argv[3], "\": ",
			 Tcl_PosixError (interp), (char *) NULL);
        return TCL_ERROR;
    }

    HttpRequestLine(src, "POST", url->path);
    HttpGeneralHeader(src);
    HttpRequestHeader(src, url->auth);
    HttpObjectHeader(src, contentType, contentEncoding, contentLength);
    HttpEndHeader(src);
    code = HttpSendObject(interp, src, obj);
    if (code == TCL_OK) {
	code = HttpRecvHeader(interp, src);
	if (code == TCL_OK) {
	    code = HttpRecvBody(interp, src, dst);
	}
    }
    Tcl_Close((Tcl_Interp *) NULL, src);
    Tcl_Close((Tcl_Interp *) NULL, dst);
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * HttpPut --
 *
 * 	This procedure implements the http put command as described
 *	in the user documentation.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
HttpPut(interp, argc, argv)
    Tcl_Interp *interp;
    int argc;
    char **argv;
{
    Tcl_Channel src, obj;
    HttpUrl *url;
    char *contentType, *contentEncoding;
    int code, contentLength;

    if (argc != 4) {
	TnmWrongNumArgs(interp, 2, argv, "url fileName");
	return TCL_ERROR;
    }

    url = HttpSplitUrl(argv[2]);
    if (url == NULL) {
	Tcl_AppendResult(interp, "url syntax error", (char *) NULL);
	return TCL_ERROR;
    }
    src = Tcl_OpenTcpClient(interp, url->port, url->host, (char *) NULL, 0, 0);
    if (src == NULL) {
	return TCL_ERROR;
    }
    Tcl_SetChannelOption(interp, src, "-translation", "crlf");

    obj = HttpOpen(argv[3], &contentType, &contentEncoding, &contentLength);
    if (! obj) {
	Tcl_Close((Tcl_Interp *) NULL, src);
	Tcl_AppendResult(interp, "can not read \"", argv[3], "\": ",
			 Tcl_PosixError(interp), (char *) NULL);
	return TCL_ERROR;
    }

    HttpRequestLine(src, "PUT", url->path);
    HttpGeneralHeader(src);
    HttpRequestHeader(src, url->auth);
    HttpObjectHeader(src, contentType, contentEncoding, contentLength);
    HttpEndHeader(src);
    code = HttpSendObject(interp, src, obj);
    if (code == TCL_OK) {
	code = HttpRecvHeader(interp, src);
    }
    Tcl_Close((Tcl_Interp *) NULL, src);
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * HttpDelete --
 *
 * 	This procedure implements the http delete command as described
 *	in the user documentation.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
HttpDelete(interp, argc, argv)
    Tcl_Interp *interp;
    int argc;
    char **argv;
{
    Tcl_Channel src;
    HttpUrl *url;
    int code;

    if (argc != 3) {
	TnmWrongNumArgs(interp, 2, argv, "url");
	return TCL_ERROR;
    }

    url = HttpSplitUrl(argv[2]);
    if (url == NULL) {
	Tcl_AppendResult(interp, "url syntax error", (char *) NULL);
	return TCL_ERROR;
    }
    src = Tcl_OpenTcpClient(interp, url->port, url->host, (char *) NULL, 0, 0);
    if (src == NULL) {
	return TCL_ERROR;
    }
    Tcl_SetChannelOption(interp, src, "-translation", "crlf");

    HttpRequestLine(src, "DELETE", url->path);
    HttpGeneralHeader(src);
    HttpRequestHeader(src, url->auth);
    HttpEndHeader(src);
    
    code = HttpRecvHeader(interp, src);
    Tcl_Close((Tcl_Interp *) NULL, src);
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * HttpServer --
 *
 * 	This procedure implements the http server command as described
 *	in the user documentation. This procedure creates a listening
 *	socket and registers a callback in the event loop to handle
 *	incoming http requests.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
HttpServer(interp, argc, argv)
    Tcl_Interp *interp;
    int argc;
    char **argv;
{
    static int port = -1;
    static Tcl_Channel channel;

    if (argc < 2 && argc > 3) {
	TnmWrongNumArgs(interp, 2, argv, "?port?");
	return TCL_ERROR;
    }

    if (argc == 2) {
	if (port > 0) {
	    sprintf(interp->result, "%d", port);
	}
	return TCL_OK;
    }

    if (port > 0) {
	Tcl_Close((Tcl_Interp *) NULL, channel);
	port = -1;
    }

    /*
     * An empty port number just closes a server and is no error.
     */

    if (argv[2][0] == '\0') {
	return TCL_OK;
    }

    port = HttpGetPort(argv[2]);
    if (port < 0) {
        Tcl_AppendResult(interp, "no such service \"", argv[3],
			 "\"", (char *) NULL);
        return TCL_ERROR;
    }

    channel = Tcl_OpenTcpServer(interp, port, (char *) 0,
				HttpAcceptProc, (ClientData) interp);
    if (channel == NULL) {
	port = -1;
	return TCL_ERROR;
    }

    sprintf(interp->result, "%d", port);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * HttpBind --
 *
 * 	This procedure implements the http bind command as described
 *	in the user documentation. Bindings are used to map URLs to
 *	Tcl scripts or simple file names.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
HttpBind(interp, argc, argv)
    Tcl_Interp *interp;
    int argc;
    char **argv;
{
    int eventType = 0;
    HttpBinding *bindPtr;

    if (argc < 4 || argc > 5) {
	TnmWrongNumArgs(interp, 2, argv, "pattern method ?script?");
	return TCL_ERROR;
    }

    /*
     * Lookup the method name and convert it in our 
     * internal representation.
     */

    eventType = TnmGetTableKey(httpEvents, argv[3]);
    if (eventType < 0) {
	TnmTable *elemPtr;
        Tcl_AppendResult(interp, "unknown method \"", argv[3],
			 "\": use one of", (char *) NULL);
	for (elemPtr = httpEvents; elemPtr->key; elemPtr++) {
	    Tcl_AppendResult(interp, elemPtr == httpEvents ? " " : ", ",
			     elemPtr->value, (char *) NULL);
	}
	return TCL_ERROR;
    }

    /*
     * Search for an already existing binding for this URL.
     */

    for (bindPtr = bindList; bindPtr; bindPtr = bindPtr->nextPtr) {
        if (eventType == bindPtr->eventType &&
	    (strcmp(bindPtr->pattern, argv[2]) == 0)) break;
    }

    if (argc == 4) {
        if (bindPtr) {
	    Tcl_SetResult(interp, bindPtr->command, TCL_STATIC);
        }
	return TCL_OK;
    }

    if (bindPtr) {
        ckfree(bindPtr->command);
	bindPtr->command = ckstrdup(argv[4]);
    } else {
	HttpBinding **bindPtrPtr = &bindList;
	int len = strlen(argv[2]);

        bindPtr = (HttpBinding *) ckalloc(sizeof(HttpBinding));
	bindPtr->eventType = eventType;
	bindPtr->pattern = ckstrdup(argv[2]);
	bindPtr->command = ckstrdup(argv[4]);

	while (*bindPtrPtr && strlen((*bindPtrPtr)->pattern) > len) {
	    bindPtrPtr = &(*bindPtrPtr)->nextPtr;
	}

	bindPtr->nextPtr = *bindPtrPtr;
	*bindPtrPtr = bindPtr;
    }

    Tcl_SetResult(interp, bindPtr->command, TCL_STATIC);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * HttpMime --
 *
 * 	This procedure implements the http mime command as described
 *	in the user documentation. It maintains a file extension to
 *	mime type conversion table.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
HttpMime(interp, argc, argv)
    Tcl_Interp *interp;
    int argc;
    char **argv;
{
    Tcl_HashTable *tablePtr = &mimeTypeTable;
    Tcl_HashEntry *entryPtr;
    Tcl_HashSearch search;
    Tcl_DString dst;
    Tcl_DStringInit(&dst);

    if (argc != 2 && argc != 4) {
	TnmWrongNumArgs(interp, 2, argv, "?type extension?");
	return TCL_ERROR;
    }

    if (argc == 4) {
	int isNew;

	entryPtr = Tcl_CreateHashEntry(tablePtr, ckstrdup(argv[3]), &isNew);
	Tcl_SetHashValue(entryPtr, (ClientData) ckstrdup(argv[2]));
    }

    entryPtr = Tcl_FirstHashEntry(tablePtr, &search);
    while (entryPtr) {
	Tcl_DStringStartSublist(&dst);
	Tcl_DStringAppendElement(&dst, Tcl_GetHashKey(tablePtr, entryPtr));
	Tcl_DStringAppendElement(&dst, (char *) Tcl_GetHashValue(entryPtr));
	Tcl_DStringEndSublist(&dst);
	entryPtr = Tcl_NextHashEntry(&search);
    }
    Tcl_DStringResult(interp, &dst);

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tnm_HttpCmd --
 *
 *	This procedure is invoked to process the "http" command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

int
Tnm_HttpCmd(clientData, interp, argc, argv)
    ClientData clientData;
    Tcl_Interp *interp;
    int argc;
    char **argv;
{
    static int initialized = 0;
    char c;

    if (! initialized) {
	initialized = 1;
	Tcl_InitHashTable(&mimeTypeTable, TCL_STRING_KEYS);
    }

    if (argc < 2) {
	TnmWrongNumArgs(interp, 1, argv, "option ?arg arg ...?");
	return TCL_ERROR;
    }

    c = argv[1][0];

    if (strcmp(argv[1], "proxy") == 0) {
        return HttpProxy(interp, argc, argv);
    } else if (strcmp(argv[1], "head") == 0) {
        return HttpHead(interp, argc, argv);
    } else if (strcmp(argv[1], "get") == 0) {
        return HttpGet(interp, argc, argv);
    } else if (strcmp(argv[1], "post") == 0) {
        return HttpPost(interp, argc, argv);
    } else if (strcmp(argv[1], "put") == 0) {
        return HttpPut(interp, argc, argv);
    } else if (strcmp(argv[1], "delete") == 0) {
        return HttpDelete(interp, argc, argv);
    } else if (strcmp(argv[1], "bind") == 0) {
        return HttpBind(interp, argc, argv);
    } else if (strcmp(argv[1], "server") == 0) {
        return HttpServer(interp, argc, argv);
    } else if (strcmp(argv[1], "mime") == 0) {
        return HttpMime(interp, argc, argv);
    }

    TnmBadOption(interp, argv[1], 
	      "get, head, post, put, delete, proxy, bind, server, or mime");
    return TCL_ERROR;
}
