Make it easier to extend cookiejar for policy reasons

3 files changed, 72 insertions, 4 deletions

diff --git a/doc/cookiejar.n b/doc/cookiejar.n
index bbfd9a3..ac71759 100644
--- a/doc/cookiejar.n
+++ b/doc/cookiejar.n
@@ -128,6 +128,33 @@ obtained from the \fB\-domainfile\fR configured at the package level.
 This method obtains the cookies for a particular HTTP request. \fIThis
 implements the http cookie jar protocol.\fR
 .TP
+\fIcookiejar\fR \fBpolicyAllow\fR \fIoperation domain path\fR
+.
+This method is called by the \fBstoreCookie\fR method to get a decision on
+whether to allow \fIoperation\fR to be performed for the \fIdomain\fR and
+\fIpath\fR. This is checked immediately before the database is updated but
+after the built-in security checks are done, and should return a boolean
+value; if the value is false, the operation is rejected and the database is
+not modified. The supported \fIoperation\fRs are:
+.RS
+.TP
+\fBdelete\fR
+.
+The \fIdomain\fR is seeking to delete a cookie.
+.TP
+\fBsession\fR
+.
+The \fIdomain\fR is seeking to create or update a session cookie.
+.TP
+\fBset\fR
+.
+The \fIdomain\fR is seeking to create or update a persistent cookie (with a
+defined lifetime).
+.PP
+The default implementation of this method just returns true, but subclasses of
+this class may impose their own rules.
+.RE
+.TP
 \fIcookiejar\fR \fBstoreCookie\fR \fIoptions\fR
 .
 This method stores a single cookie from a particular HTTP response. Cookies
@@ -142,7 +169,7 @@ stored is returned. If just \fIhost\fR (which may be a hostname or a domain
 name) is supplied, the list of cookie keys stored for that host is returned.
 If both \fIhost\fR and \fIkey\fR are supplied, the value for that key is
 returned; it is an error if no such host or key match exactly.
-.SH "EXAMPLE"
+.SH "EXAMPLES"
 .PP
 The simplest way of using a cookie jar is to just permanently configure it at
 the start of the application.
@@ -157,6 +184,29 @@ http::configure -cookiejar [\fBhttp::cookiejar new\fR $cookiedb]
 # No further explicit steps are required to use cookies
 set tok [http::geturl http://core.tcl.tk/]
 .CE
+.PP
+To only allow a particular domain to use cookies, perhaps because you only
+want to enable a particular host to create and manipulate sessions, create a
+subclass that imposes that policy.
+.PP
+.CS
+package require http
+\fBpackage require cookiejar\fR
+
+oo::class create MyCookieJar {
+    superclass \fBhttp::cookiejar\fR
+
+    method \fBpolicyAllow\fR {operation domain path} {
+        return [expr {$domain eq "my.example.com"}]
+    }
+}
+
+set cookiedb ~/.tclcookies.db
+http::configure -cookiejar [MyCookieJar new $cookiedb]
+
+# No further explicit steps are required to use cookies
+set tok [http::geturl http://core.tcl.tk/]
+.CE
 .SH "SEE ALSO"
 http(n), oo::class(n), sqlite3(n)
 .SH KEYWORDS
diff --git a/doc/http.n b/doc/http.n
index 572f19a..7845e60 100644
--- a/doc/http.n
+++ b/doc/http.n
@@ -818,9 +818,9 @@ with different names in any request.
 \fIcookieJar \fBstoreCookie \fIcookieDictionary\fR
 .
 This command asks the cookie jar to store a particular cookie that was
-returned by a request. The cookie (which will have been parsed by the http
-package) is described by a dictionary, \fIcookieDictionary\fR, that may have
-the following keys:
+returned by a request; the result of this command is ignored. The cookie
+(which will have been parsed by the http package) is described by a
+dictionary, \fIcookieDictionary\fR, that may have the following keys:
 .RS
 .TP
 \fBdomain\fR
diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl
index 1fc1ffe..309ca7a 100644
--- a/library/http/cookiejar.tcl
+++ b/library/http/cookiejar.tcl
@@ -589,6 +589,12 @@ package provide cookiejar \
 	return 0
     }
 
+    # A defined extension point to allow users to easily impose extra policies
+    # on whether to accept cookies from a particular domain and path.
+    method policyAllow {operation domain path} {
+	return true
+    }
+
     method storeCookie {options} {
 	db transaction {
 	    if {[my BadDomain $options]} {
@@ -598,6 +604,10 @@ package provide cookiejar \
 	    set persistent [dict exists $options expires]
 	    dict with options {}
 	    if {!$persistent} {
+		if {![my policyAllow session $domain $path]} {
+		    log warn "bad cookie: $domain prohibited by user policy"
+		    return
+		}
 		db eval {
 		    INSERT OR REPLACE INTO sessionCookies (
 			secure, domain, path, key, value, originonly, creation,
@@ -612,6 +622,10 @@ package provide cookiejar \
 		log debug "defined session cookie for %s" \
 			[locn $secure $domain $path $key]
 	    } elseif {$expires < $now} {
+		if {![my policyAllow delete $domain $path]} {
+		    log warn "bad cookie: $domain prohibited by user policy"
+		    return
+		}
 		db eval {
 		    DELETE FROM persistentCookies
 		    WHERE domain = $domain AND path = $path AND key = $key
@@ -627,6 +641,10 @@ package provide cookiejar \
 		log debug "deleted %d cookies for %s" \
 			$del [locn $secure $domain $path $key]
 	    } else {
+		if {![my policyAllow set $domain $path]} {
+		    log warn "bad cookie: $domain prohibited by user policy"
+		    return
+		}
 		db eval {
 		    INSERT OR REPLACE INTO persistentCookies (
 			secure, domain, path, key, value, originonly, expiry,