path: root/appl/charon/cookiesrv.b

implement Cookiesrv;
include "sys.m";
include "bufio.m";
include "string.m";
include "daytime.m";
include "cookiesrv.m";

sys: Sys;
bufio: Bufio;
S: String;
daytime: Daytime;

Iobuf: import bufio;

Cookielist: adt {
	prev: cyclic ref Cookielist;
	next: cyclic ref Cookie;
};

Cookie: adt {
	name: string;
	value: string;
	dom: string;
	path: string;
	expire: int;		# seconds from epoch, -1 => not set, 0 => expire now
	secure: int;
	touched: int;
	link: cyclic ref Cookielist;	# linkage for list of cookies in the same domain
};

Domain: adt {
	name: string;
	doms: cyclic list of ref Domain;
	cookies: ref Cookielist;
};

MAXCOOKIES: con 300;		# total number of cookies allowed
LISTMAX: con 20;			# max number of cookies per Domain
PURGENUM: con 30;			# number of cookies to delete when freeing up space
MAXCKLEN: con 4*1024;		# max cookie length

ncookies := 0;
doms: list of ref Domain;
now: int;	# seconds since epoch
cookiepath: string;
touch := 0;

start(path: string, saveinterval: int): ref Client
{
	sys = load Sys Sys->PATH;
	bufio = load Bufio Bufio->PATH;
	if (bufio == nil) {
		sys->print("cookiesrv: cannot load %s: %r\n", Bufio->PATH);
		return nil;
	}
	S = load String String->PATH;
	if (S == nil) {
		sys->print("cookiesrv: cannot load %s: %r\n", String->PATH);
		return nil;
	}
	daytime = load Daytime Daytime->PATH;
	if (daytime == nil) {
		sys->print("cookiesrv: cannot load %s: %r\n", Daytime->PATH);
		return nil;
	}

	cookiepath = path;
	now = daytime->now();

	# load the cookie file
	# order is most recently touched first 
	iob := bufio->open(cookiepath, Sys->OREAD);
	if (iob != nil) {
		line: string;
		while ((line = iob.gets('\n')) != nil) {
			if (line[len line -1] == '\n')
				line = line[:len line -1];
			loadcookie(line);
		}
		iob.close();
		iob = nil;
		expire();
	}
	fdc := chan of ref Sys->FD;
	spawn server(fdc, saveinterval);
	fd := <- fdc;
	if (fd == nil)
		return nil;
	return ref Client(fd);
}

addcookie(ck: ref Cookie, domlist: ref Cookielist)
{
	(last, n) := lastlink(domlist);
	if (n == LISTMAX)
		rmcookie(last.prev.next);
	if (ncookies == MAXCOOKIES)
		rmlru();
	ck.link = ref Cookielist(domlist, domlist.next);
	if (domlist.next != nil)
		domlist.next.link.prev = ck.link;
	domlist.next = ck;
	ncookies++;
}

rmcookie(ck: ref Cookie)
{
	nextck := ck.link.next;
	ck.link.prev.next = nextck;
	if (nextck != nil) 
		nextck.link.prev = ck.link.prev;
	ncookies--;
}

lastlink(ckl: ref Cookielist): (ref Cookielist, int)
{
	n := 0;
	for (nckl := ckl.prev; nckl != nil; nckl = nckl.prev)
		n++;
	for (; ckl.next != nil; ckl = ckl.next.link)
		n++;
	return (ckl, n);
}

rmlru()
{
	cka := array [ncookies] of ref Cookie;
	ix := getallcookies(doms, cka, 0);
	if (ix < PURGENUM)
		return;
	mergesort(cka, nil, SORT_TOUCHED);
	for (n := 0; n < PURGENUM; n++)
		rmcookie(cka[n]);
}

getallcookies(dl: list of ref Domain, cka: array of ref Cookie, ix: int): int
{
	for (; dl != nil; dl = tl dl) {
		dom := hd dl;
		for (ck := dom.cookies.next; ck != nil; ck = ck.link.next)
			cka[ix++] = ck;
		ix = getallcookies(dom.doms, cka, ix);
	}
	return ix;
}

isipaddr(s: string): int
{
	# assume ipaddr if only numbers and '.'s
	# should maybe count the dots too (what about IPV6?)
	return S->drop(s, ".0123456789") == nil;
}

setcookie(ck: ref Cookie)
{
	parent, dom: ref Domain;
	domain := ck.dom;
	if (isipaddr(domain))
		(parent, dom, domain) = getdom(doms, nil, domain);
	else
		(parent, dom, domain) = getdom(doms, domain, nil);

	if (dom == nil)
		dom = newdom(parent, domain);

	for (oldck := dom.cookies.next; oldck != nil; oldck = oldck.link.next) {
		if (ck.name == oldck.name && ck.path == oldck.path) {
			rmcookie(oldck);
			break;
		}
	}
	if (ck.expire > 0 && ck.expire <= now)
		return;
	addcookie(ck, dom.cookies);
}

expire()
{
	cka := array [ncookies] of ref Cookie;
	ix := getallcookies(doms, cka, 0);
	for (i := 0; i < ix; i++) {
		ck := cka[i];
		if (ck.expire > 0 && ck.expire < now)
			rmcookie(ck);
	}
}

newdom(parent: ref Domain, domain: string): ref Domain
{
	while (domain != "") {
		(lhs, rhs) := splitdom(domain);
		d := ref Domain(rhs, nil, ref Cookielist(nil, nil));
		if (parent == nil)
			doms = d :: doms;
		else
			parent.doms = d :: parent.doms;
		parent = d;
		domain = lhs;
	}
	return parent;
}

getdom(dl: list of ref Domain, lhs, rhs: string): (ref Domain, ref Domain, string)
{
	if (rhs == "")
		(lhs, rhs) = splitdom(lhs);
	parent: ref Domain;
	while (dl != nil) {
		d := hd dl;
		if (d.name != rhs) {
			dl = tl dl;
			continue;
		}
		# name matches
		if (lhs == nil)
			return (parent, d, rhs);
		parent = d;
		(lhs, rhs) = splitdom(lhs);
		dl = d.doms;
	}
	return (parent, nil, lhs+rhs);
}

# returned list is in shortest to longest domain match order
getdoms(dl: list of ref Domain, lhs, rhs: string): list of ref Domain
{
	if (rhs == "")
		(lhs, rhs) = splitdom(lhs);
	for (; dl != nil; dl = tl dl) {
		d := hd dl;
		if (d.name == rhs) {
			if (lhs == nil)
				return d :: nil;
			(lhs, rhs) = splitdom(lhs);
			return d :: getdoms(d.doms, lhs, rhs);
		}
	}
	return nil;
}

server(fdc: chan of ref Sys->FD, saveinterval: int)
{
	sys->pctl(Sys->NEWPGRP|Sys->FORKNS, nil);
	sys->bind("#s", "/chan", Sys->MBEFORE);
	fio := sys->file2chan("/chan", "ctl");
	if (fio == nil) {
		fdc <-= nil;
		return;
	}
	fd := sys->open("/chan/ctl", Sys->OWRITE);
	fdc <-= fd;
	if (fd == nil)
		return;
	fd = nil;
		
	tick := chan of int;
	spawn ticker(tick, 1*60*1000);	# clock tick once a minute
	tickerpid := <- tick;

	modified := 0;
	savetime := now + saveinterval;

	for (;;) alt {
	now = <- tick =>
		expire();
		if (saveinterval != 0 && now > savetime) {
			if (modified) {
				save();
				modified = 0;
			}
			savetime = now + saveinterval;
		}
	(nil, line, nil, rc) := <- fio.write =>
		now = daytime->now();
		if (rc == nil) {
			kill(tickerpid);
			expire();
			save();
			return;
		}
		loadcookie(string line);
		alt {
		rc <-= (len line, nil) =>
			;
		* =>
			;
		};
		modified = 1;
	}
}

ticker(tick: chan of int, ms: int)
{
	tick <-= sys->pctl(0, nil);
	for (;;) {
		sys->sleep(ms);
		tick <-= daytime->now();
	}
}

# sort orders
SORT_TOUCHED, SORT_PATHLEN: con iota;

mergesort(a, b: array of ref Cookie, order: int)
{
	if (b == nil)
		b = array [len a] of ref Cookie;
	r := len a;
	if (r > 1) {
		m := (r-1)/2 + 1;
		mergesort(a[0:m], b[0:m], order);
		mergesort(a[m:], b[m:], order);
		b[0:] = a;
		for ((i, j, k) := (0, m, 0); i < m && j < r; k++) {
			if (greater(b[i], b[j], order))
				a[k] = b[j++];
			else
				a[k] = b[i++];
		}
		if (i < m)
			a[k:] = b[i:m];
		else if (j < r)
			a[k:] = b[j:r];
	}
}

greater(x, y: ref Cookie, order: int): int
{
	if (y == nil)
		return 0;
	case order {
	SORT_TOUCHED =>
		if (x.touched > y.touched)
			return 1;
	SORT_PATHLEN =>
		if (len x.path < len y.path)
			return 1;
	}
	return 0;
}

cookie2str(ck: ref Cookie): string
{
	if (len ck.name +1 > MAXCKLEN)
		return "";
	namval := sys->sprint("%s=%s", ck.name, ck.value);
	if (len namval > MAXCKLEN)
		namval = namval[:MAXCKLEN];
	return sys->sprint("%s\t%s\t%d\t%d\t%s", ck.dom, ck.path, ck.expire, ck.secure, namval);
}

loadcookie(ckstr: string)
{
	(n, toks) := sys->tokenize(ckstr, "\t");
	if (n < 5)
		return;
	dom, path, exp, sec, namval: string;
	(dom, toks) = (hd toks, tl toks);
	(path, toks) = (hd toks, tl toks);
	(exp, toks) = (hd toks, tl toks);
	(sec, toks) = (hd toks, tl toks);
	(namval, toks) = (hd toks, tl toks);

	# some sanity checks
	if (dom == "" || path == "" || path[0] != '/')
		return;

	(name, value) := S->splitl(namval, "=");
	if (value == nil)
		return;
	value = value[1:];
	ck := ref Cookie(name, value, dom, path, int exp, int sec, touch++, nil);
	setcookie(ck);
}

Client.set(c: self ref Client, host, path, cookie: string)
{
	ck := parsecookie(host, path, cookie);
	if (ck == nil)
		return;
	b := array of byte cookie2str(ck);
	sys->write(c.fd, b, len b);
}

Client.getcookies(nil: self ref Client, host, path: string, secure: int): string
{
	dl: list of ref Domain;
	if (isipaddr(host))
		dl = getdoms(doms, nil, host);
	else {
		# note some domains match hosts
		# e.g. site X.com has to set a cookie for '.X.com'
		# to get around the netscape '.' count check
		# this messes up our domain checking
		# putting a '.' on the front of host is a safe way of handling this
#		host = "." + host;
		dl = getdoms(doms, host, nil);
	}
	cookies: list of ref Cookie;
	for (; dl != nil; dl = tl dl) {
		ckl := (hd dl).cookies;
		for (ck := ckl.next; ck != nil; ck = ck.link.next) {
			if (ck.secure && !secure)
				continue;
			if (!S->prefix(ck.path, path))
				continue;
			ck.touched = touch++;
			cookies = ck :: cookies;
		}
	}
	if (cookies == nil)
		return "";

	# sort w.r.t path len and creation order
	cka := array [len cookies] of ref Cookie;
	for (i := 0; cookies != nil; cookies = tl cookies)
		cka[i++] = hd cookies;

	mergesort(cka, nil, SORT_PATHLEN);

	s := sys->sprint("%s=%s", cka[0].name, cka[0].value);
	for (i = 1; i < len cka; i++)
		s += sys->sprint("; %s=%s", cka[i].name, cka[i].value);
	return s;
}

save()
{
	fd := sys->create(cookiepath, Sys->OWRITE, 8r600);
	if (fd == nil)
		return;
	cka := array [ncookies] of ref Cookie;
	ix := getallcookies(doms, cka, 0);
	mergesort(cka, nil, SORT_TOUCHED);

	for (i := 0; i < ix; i++) {
		ck := cka[i];
		if (ck.expire > now)
			sys->fprint(fd, "%s\n", cookie2str(cka[i]));
	}
}

parsecookie(dom, path, cookie: string): ref Cookie
{
	defpath := "/";
	if (path != nil)
		(defpath, nil) = S->splitr(path, "/");

	(nil, toks) := sys->tokenize(cookie, ";");
	namval := hd toks;
	toks = tl toks;

	(name, value) := S->splitl(namval, "=");
	name = trim(name);
	if (value != nil && value[0] == '=')
		value = value[1:];
	value = trim(value);

	ck := ref Cookie(name, value, dom, defpath, -1, 0, 0, nil);
	for (; toks != nil; toks = tl toks) {
		(name, value) = S->splitl(hd toks, "=");
		if (value != nil && value[0] == '=')
			value = value[1:];
		name = trim(name);
		value = trim(value);
		case S->tolower(name) {
		"domain" =>
			ck.dom = value;
		"expires" =>
			ck.expire = date2sec(value);
		"path" =>
			ck.path = value;
		"secure" =>
			ck.secure = 1;
		}
	}
	if (ckcookie(ck, dom, path))
		return ck;
	return nil;
}

# Top Level Domains as defined in Netscape cookie spec
tld := array [] of {
	".com", ".edu", ".net", ".org", ".gov", ".mil", ".int"
};

ckcookie(ck: ref Cookie, host, path: string): int
{
#dumpcookie(ck, "CKCOOKIE");
	if (ck == nil)
		return 0;
	if (ck.path == "" || ck.dom == "")
		return 0;
	if (host == "" || path == "")
		return 1;

# netscape does no path check on accpeting a cookie
# any page can set a cookie on any path within its domain.
# the filtering is done when sending cookies back to the server
#	if (!S->prefix(ck.path, path))
#		return 0;

	if (host == ck.dom)
		return 1;
	if (ck.dom[0] != '.' || len host < len ck.dom)
		return 0;

	ipaddr := S->drop(host, ".0123456789") == nil;
	if (ipaddr)
		# ip addresses have to match exactly
		return 0;

	D := host[len host - len ck.dom:];
	if (D != ck.dom)
		return 0;

	# netscape specific policy
	ndots := 0;
	for (i := 0; i < len D; i++)
		if (D[i] == '.')
			ndots++;
	for (i = 0; i < len tld; i++) {
		if (len D >= len tld[i] && D[len D - len tld[i]:] == tld[i]) {
			if (ndots < 2)
				return 0;
			return 1;
		}
	}
	if (ndots < 3)
		return 0;
	return 1;
}

trim(s: string): string
{
	is := 0;
	ie := len s;
	while(is < ie) {
		c := s[is];
		if(!(c == ' ' || c == '\t'))
			break;
		is++;
	}
	if(is == ie)
		return "";
	while(ie > is) {
		c := s[ie-1];
		if(!(c == ' ' || c == '\t'))
			break;
		ie--;
	}
	if(is >= ie)
		return "";
	if(is == 0 && ie == len s)
		return s;
	return s[is:ie];
}

kill(pid: int)
{
	sys->fprint(sys->open("/prog/"+string pid+"/ctl", Sys->OWRITE), "kill");
}

date2sec(date: string): int
{
	Tm: import daytime;
	tm := daytime->string2tm(date);
	if(tm == nil || tm.year < 70 || tm.zone != "GMT")
		t := -1;
	else
		t = daytime->tm2epoch(tm);
	return t;
}

dumpcookie(ck: ref Cookie, msg: string)
{
	if (msg != nil)
		sys->print("%s: ", msg);
	if (ck == nil)
		sys->print("NIL\n");
	else {
		dbgval := ck.value;
		if (len dbgval > 10)
			dbgval = dbgval[:10];
		sys->print("dom[%s], path[%s], name[%s], value[%s], secure=%d\n", ck.dom, ck.path, ck.name, dbgval, ck.secure);
	}
}

splitdom(s: string): (string, string)
{
	for (ie := len s -1; ie > 0; ie--)
		if (s[ie] == '.')
			break;
	return (s[:ie], s[ie:]);
}