########## datastate.tcl
# This file contains core routines for handling the persistent
# data with timeouts.
#
# This file is part of SAUCE, a very picky anti-spam receiver-SMTP.
# SAUCE is Copyright (C) 1997-2003 Ian Jackson
#
# 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, 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, write to the Free Software Foundation,
# Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 
#
# $Id: datastate.tcl,v 1.15 2006/04/03 01:02:07 ian Exp $

# This routine maintains permanent database(s) of information about
# key(s).  Each database maps a key to a state value.  The state
# values are defined by the caller.  The states may time out, and be
# replaced by other states, as defined by the caller.

# We use a cdb-wr from chiark-tcl.  Keys are the key as supplied to
# ds_set (possibly quoted if specified during bind).
# Values are of the form
#   0xHHHHHHHHHHHHHHHH ultimate-value 0xHHHHHHHHHHHHHHHH penultimate-value...
#    ... 0xHHHHHHHHHHHHHHHH current-value

# The variables used internally are:
#  ds__cdbwr.DB      cdb-wr handle
#  ds__perm.DB.(KEY) Permanent settings (VALUE only)
#  ds__quotekey.DB   0 or 1
#  ds__regexp.DB     Regexp which values must match

load chiark_tcl_cdb-1.so

#---------- general utilities ----------

proc ds__proctimeouts {db telemvar now} {
    upvar 1 $telemvar telem
    set changed 0

    debug 4 ds__proctimeouts $db at $now $telem ...
    while {[llength $telem] && [lindex $telem end-1] < $now} {
	set telem [lrange $telem 0 end-2]
	set changed 1
    }
    debug 3 ds__proctimeouts $db at $now $telem !
    return $changed
}

proc ds__setentry {db key telem} {
    upvar #0 ds__cdbwr.$db cdb
    if {[llength $telem]} {
	debug 3 ds__setentry $db $key := $telem
	cdb-wr update $cdb $key $telem
    } else {
	debug 3 ds__setentry $db $key :=<>
	cdb-wr delete $cdb $key
    }
}

proc ds__checkvalue {db value} {
    upvar #0 ds__regexp.$db regexp
    if {![regexp -- $regexp $value]} { error "bad db value $value for $db" }
}

proc ds__key_quote {key} {
    set keyquoted {}
    while {[regexp -nocase {^([-=_+@.%0-9a-z]*)([^-=_+@.%0-9a-z])(.*)$} \
            $key dummy l ch key]} {
	binary scan $ch H* hex
	append keyquoted $l {\x} $hex
    }
    append keyquoted $key
    return $keyquoted
}

proc ds__key_quote_maybe {db keyvar} {
    upvar #0 ds__quotekey.$db doquote
    if {!$doquote} return
    upvar 1 $keyvar key
    set key [ds__key_quote $key]
}

#---------- retrieval ----------

proc ds_get {db key} {
    # Returns the current value in DB of KEY.  If the key is not
    # found (or has expired), returns `unknown'.
    ds__key_quote_maybe $db key
    upvar #0 ds__perm.$db.($key) perm
    upvar #0 ds__cdbwr.$db cdb
    if {[info exists perm]} {
	debug 2 ds_get $db $key ?.=> $perm
	return $perm
    }
    set telem [cdb-wr lookup $cdb $key {}]
    if {[ds__proctimeouts $db telem [clock seconds]]} {
	ds__setentry $db $key $telem
    }
    if {[llength $telem]} {
	set value [lindex $telem end]
	ds__checkvalue $db $value
	debug 2 ds_get $db $key ?=> $value
    } else {
	set value unknown
	debug 2 ds_get $db $key ?=>- $value
    }
    return $value
}

#---------- updating ----------

proc ds_set {db key args} {
    # Sets, in DB, the value of KEY.  The remaining ARGS should come
    # in pairs VALUE TIMEOUT, where VALUE is the value, and TIMEOUT is
    # the duration in seconds for which the value should hold.  VALUEs
    # should consist of alphanumerics.

    ds__key_quote_maybe $db key
    upvar #0 ds__perm.$db.($key) perm

    set now [clock seconds]

    if {[info exists perm]} {
	debug 2 ds_set $db $key (:=$args) .= $perm
	return
    }

    debug 2 ds_set $db at $now $key := $args

    set telem {}
    foreach {value timeout} $args {
	ds__checkvalue $db $value
	incr timeout $now
	set telem [lreplace $telem 0 -1 [format 0x%016x $timeout] $value]
    }

    ds__proctimeouts $db telem $now
    ds__setentry $db $key $telem
}

proc ds_setforever {db key value} {
    # Sets, in DB, the value of KEY to VALUE, forever.  This is not
    # recorded in any database files - it is assumed to be the
    # result of static configuration.
    ds__key_quote_maybe $db key
    upvar #0 ds__perm.$db.($key) perm

    debug 2 ds_setforever $db $key :=. $value
    ds__checkvalue $db $value
    set perm $value
}

#---------- binding and machinery ----------

proc ds__oninfo {db args} {
    log notice "$db cdb-wr $args"
}

proc ds__clockseconds {} { format 0x%016x [clock seconds] }

proc ds_bind {db prefix regexp quotekey} {
    # Binds the database DB to files with prefix FILEPREFIX.
    # This will load the database, and it will also cause
    # updates to be recorded there.  FILEPREFIX is passed to cdb-wr.
    # Values must match REGEXP (though ds_get may also return `unknown').

    set now [clock seconds]
    debug 3 ds_bind $db $prefix at $now

    upvar #0 ds__cdbwr.$db cdb
    foreach v {regexp quotekey} {
	upvar #0 ds__${v}.$db toset
	set toset [set $v]
    }

    set cdb [cdb-wr open $prefix [list ds__oninfo $db] ds__clockseconds]
}
