src/generic/cookie.ws3

#
# cookie.ws3 -- session context using cookies
# nca-073-9
# 
# Copyright (C) 1999 by Netcetera AG.
# Copyright (C) 2001 by Apache Software Foundation.
# All rights reserved.
# 
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# @(#) $Id$
#

# Cookie-Specs: http://www.netscape.com/newsref/std/cookie_spec.html


proc web::cookiecontext {ctxmgrname args} {

    # correct namespace (relative to caller)
    if {![string match ::* $ctxmgrname]} {
	set ctxmgrname [uplevel namespace current]::$ctxmgrname
    }

    web::sessioncontextfactory $ctxmgrname
    
    # set default values for some properties
    namespace eval $ctxmgrname {

        # where to send cookie to
        variable _channel ""
        variable _domain ""
        variable _path ""
        variable _expires "24 hours"
        # key to be used for key-value pair in cookie
	variable _crypt 1
	# secure flag of cookie
	variable _secure 0
    }

    # parse args for this
    set argc [llength $args]
    set baseargs {}
    for {set i 0} {$i < $argc} {incr i} {
	set arg [lindex $args $i]
	set found 0
	foreach opt {channel domain path expires secure crypt} {
	    if {[string equal $arg -$opt]} {
		if {[incr i]>$argc} {
		    error "argument -$opt needs a value."
		}
		set ${ctxmgrname}::_$opt [lindex $args $i]
		set found 1
		break
	    }
	}
	if {!$found} {
	    lappend baseargs $arg
	}
    }

    # now eat up remaining args
    ${ctxmgrname}::_parseargs $baseargs

    # getCookie - find my cookie
    proc ${ctxmgrname}::_getCookie {id} {
        ::set cookie [web::request HTTP_COOKIE]
        foreach v [split $cookie ";"] {
	    # get key and value: note: some cookies (e.g.. Google analytics)
	    # also use = in the value, so a simple split with =; does 
	    # not always work...
	    set key [string trim [lindex [split $v =] 0]]
	    set value [string trim [join [lrange [split $v =] 1 end] =]]
	    lappend kvlist $key $value
        }
        # search for $datatag
        foreach {key value} $kvlist {
            if {[string compare $key $id] == 0} {
                return $value
            }
        }
        error "no matching cookie found"
    }

    # 
    # init (overwrite sessctx init here)
    proc ${ctxmgrname}::init {id {create 0}} {
	cunset
	# load it
        if { [catch {_load $id $create}]} {
            # .. or make new
            new $id
        }
    }

    # Load - load a state from a cookie
    proc ${ctxmgrname}::load {id {create 0}} {
        variable _crypt
	variable _id

        if {$_crypt} {
            namespace eval [namespace current] [web::decrypt [_getCookie $id]]
        } else {
            namespace eval [namespace current] [web::uridecode [_getCookie $id]]
        }
	set _id $id
    }

    # Save cookie
    proc ${ctxmgrname}::save {id {doInvalidate 0}} {

        variable _channel
        variable _domain
        variable _path
        variable _expires
        variable _secure

	set ochannel [web::response]
        if {[string length $_channel]} {
	    web::response -select $_channel
	}

        # test if header was not already sent
	if {[web::response -sendheader] == 0} {
	    web::log ws3.error "web::cookiecontext::commit: commit too late, header already sent"
	    if {![info exists ochannel]} {
		web::response -select $ochannel
	    }
	    error "cookie commit too late (header already sent)"
	}

        # write the data
	variable _crypt
	if {$_crypt} {
	    set data [web::encrypt [dump]]
	} else {
	    set data [web::uriencode [dump]]
	}

	set cookie "$id=$data"

	if { $doInvalidate } {
	    append cookie "; expires=Sat, 01-Jan-2000 00:00:00 GMT"
	} else {

	    if { $data == "{}" || $data == ""} {
		set cookie "$id=; expires=Sat, 01-Jan-2000 00:00:00 GMT"
	    } else {

		# write the expiry-date
		if {[regexp {^[0-9]+$} $_expires]} {
		    # expiry given as epoch seconds
		    set expsec $_expires
		} elseif {[string length $_expires] && ![catch {clock scan $_expires} msg] } {
		    # expiry given in tcl scannable date-time string
		    # incl. "day", "tomorrow", "week" ...
		    set expsec $msg
		}

		if {[info exists expsec]} {
		    # we have an (optional) expiry

		    # we'd like to just format directly, but Tcl's locale
		    # handling (at least in 8.4.X) shows strange side effects
		    # when we play around with LC_TIME etc...
		    # And since we need a specific locale here, we just
		    # construct it manually ... (sorry)
		    # we tried the unset env(LC_TIME) stuff ... it didn't
		    # work reliably (and strange enough: now it's actually
		    # faster than before ;-)
		    set dayNum [clock format $expsec -format "%w" -gmt true]
		    set day [lindex "Sun Mon Tue Wed Thu Fri Sat" $dayNum]
		    scan [clock format $expsec -format "%m" -gmt true] "%d" monthNum
		    # monthNum is not zero based -> dummy entry in the list
		    set month [lindex "NaM Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec" $monthNum]
		    set expstr [clock format $expsec -format "$day, %d-$month-%Y %H:%M:%S GMT" -gmt true]
		    append cookie "; expires=$expstr"
		}
	    }
	}

	# write the path
	if {[string length $_path]} {
	    append cookie "; path=$_path"
	}
	# write the domain
	if {[string length $_domain]} {
	    append cookie "; domain=$_domain"
        }
        # write secure if required 
        if {$_secure} {
            append cookie "; secure"
        }

        # write the cookie into the header of the channel 
	web::response -set Set-Cookie $cookie

	if {![info exists ochannel]} {
	    web::response -select $ochannel
	}
    }

    # invalidate context
    proc ${ctxmgrname}::invalidate {} {
 
	# delete in namespace
	cunset
 
	# mark for deletion on client side
	save [id] 1
    }
}