# Copyright 2007-2008, Matthew Welland.
# 
#  This program is made available under the GNU GPL version 2.0 or
#  greater. See the accompanying file COPYING for details.
# 
#  This program is distributed WITHOUT ANY WARRANTY; without even the
#  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
#  PURPOSE.

include install.cfg

SRCFILES    = stml.scm misc-stml.scm session.scm sqltbl.scm formdat.scm setup.scm stmlrun.scm keystore.scm html-filter.scm cookie.scm
MODULEFILES = $(wildcard modules/*/*-mod.scm)
SOFILES     = $(MODULEFILES:%.scm=%.so)
CFILES      = $(MODULEFILES:%.scm=%.c)
OFILES      = $(MODULEFILES:%.scm=%.o)
OFILES      = $(SRCFILES:%.scm=%.o)
TARGFILES   = $(notdir $(SOFILES))
MODULES     = $(addprefix $(TARGDIR)/modules/,$(TARGFILES))

install : $(TARGDIR)/stmlrun $(LOGDIR) $(MODULES)

all : $(SOFILES)

stmlrun : stmlrun.scm formdat.scm  misc-stml.scm  session.scm stml.scm \
          setup.scm html-filter.scm requirements.scm keystore.scm \
          sugar.scm
	csc stmlrun.scm
# stmlrun : stmlrun.scm formdat.scm  misc-stml.scm  session.scm stml.scm \
#           setup.scm html-filter.scm requirements.scm keystore.scm \
#           cookie.scm sqltbl.scm
# 	csc stmlrun.scm


$(TARGDIR)/stmlrun : stmlrun 
	cp stmlrun $(TARGDIR)
	chmod a+rx $(TARGDIR)/stmlrun

$(TARGDIR)/modules :
	mkdir -p $(TARGDIR)/modules

$(MODULES) : $(SOFILES) $(TARGDIR)/modules
	cp $< $@

stmlrun : $(OFILES) stmlrun.scm requirements.scm
	csc $(OFILES) -o stmlrun

# logging currently relies on this
#
$(LOGDIR) :
	mkdir -p $(LOGDIR)
	chmod a+rwx $(LOGDIR)

test: kiatoa.db
test: kiatoa.db cookie.so
	echo '(exit)'| csi -q  ./tests/test.scm 

# modules
#
%.so : %.scm
	csc -I modules/* -s $<

all : $(SOFILES)
%.o : %.scm
	csc -c $<

# Cookie is a special case for now. Make a loadable so for test
# Complile it in by include (see dependencies above).
dbi.so : dbi.scm
	csc -i dbi.scm
cookie.so : cookie.scm
	csc -s cookie.scm

installdbi : dbi.so
	cp dbi.so /usr/local/lib/chicken/3/
# 

# $(CFILES): build/%.c: ../scm/%.scm ../scm/macros.scm
# 	chicken $< -output-file $@
# 
# 
# $(OFILES): src/%.o: src/%.c
# 	gcc -c $< `chicken-config -cflags` -o $@
# 

;;;
;;; cookie.scm - parse and construct http state information
;;;  
;;;   Copyright (c) 2000-2003 Shiro Kawai, All rights reserved.
;;;   
;;;   Redistribution and use in source and binary forms, with or without
;;;   modification, are permitted provided that the following conditions
;;;   are met:
;;;   
;;;   1. Redistributions of source code must retain the above copyright
;;;      notice, this list of conditions and the following disclaimer.
;;;  
;;;   2. Redistributions in binary form must reproduce the above copyright
;;;      notice, this list of conditions and the following disclaimer in the
;;;      documentation and/or other materials provided with the distribution.
;;;  
;;;   3. Neither the name of the authors nor the names of its contributors
;;;      may be used to endorse or promote products derived from this
;;;      software without specific prior written permission.
;;;  
;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;  
;;;  Ported to Chicken by Reed Sheridan
;;;

;; Parser and constructor of http "Cookies" defined in
;; RFC 2965 HTTP state managemnet mechanism
;;   <ftp://ftp.isi.edu/in-notes/rfc2965.txt>
;; See also
;; RFC 2964 Use of HTTP state management
;;   <ftp://ftp.isi.edu/in-notes/rfc2964.txt>
;; The parser also supports the old Netscape spec
;;   <http://www.netscape.com/newsref/std/cookie_spec.html>

(declare (unit cookie))
(require-extension srfi-1 srfi-13 srfi-14 regex)
(declare (export parse-cookie-string construct-cookie-string))

#>
#include <time.h>
<#

(define fmt-time
  (foreign-lambda* c-string ((long secs_since_epoch))
    "static char buf[256];"
    "time_t t = (time_t) secs_since_epoch;"
    "strftime(buf, sizeof(buf), \"%a, %d-%b-%Y %H:%M:%S GMT\", gmtime(&t));"
    "return(buf);"))

;; utility fn.  breaks  ``attr=value;attr=value ... '' into alist.
;; version is a cookie version.  if version>0, we allow comma as the
;; delimiter as well as semicolon.
(define (parse-av-pairs input version)
  (define attr-regexp
    (if (= version 0)
        (regexp "\\s*([\\w$_-]+)\\s*([=\\;]\\s*)?")
        (regexp "\\s*([\\w$_-]+)\\s*([=\\;,]\\s*)?")))
  (define attr-delim
    (if (= version 0) #\; (char-set #\, #\\ #\;)))
  
  (define (read-attr input r)
    (cond ((string-null? input) (reverse! r))
          ((string-search attr-regexp input)
           => (lambda (m)
                (if (and-let* ((delimiter (third m))) ;;is an attr_value pai
		      (string-prefix? "=" delimiter))
                    (let ((attr (second m))
                          (rest (string-search-after attr-regexp input)))
                      (if (string-prefix? "\"" rest)
                          (read-token-quoted attr (string-drop rest 1) r)
                          (read-token attr rest r)))
                    (read-attr (string-search-after attr-regexp input) ;; Skip ahead if broken input?
                               (alist-cons (second m) #f r)))))
          (else
           ;; the input is broken; for now, we ignore the rest.
           (reverse! r))))
  (define (read-token attr input r)
    (cond ((string-index input attr-delim)
           => (lambda (i)
                (read-attr (string-drop input (+ i 1))
                           (alist-cons attr
				       (string-trim-right (string-take input i))
				       r))))
          (else
           (reverse! (alist-cons attr (string-trim-right input) r)))))
  (define (read-token-quoted attr input r)
    (let loop ((input input)
               (partial '()))
      (cond ((string-index input (char-set #\\ #\"))
             => (lambda (i)
                  (let ((c (string-ref input i)))
                    (if (char=? c #\\)
                        (if (< (string-length input) (+ i 1))
                            (error-unterminated attr)
                            (loop (string-drop input (+ i 2))
                                  (cons* (string (string-ref input (+ i 1)))
                                         (string-take input i)
                                         partial)))
                        (read-attr (string-drop input (+ i 1))
                                   (alist-cons attr
					       (string-concatenate-reverse
						(cons (string-take input i)
						      partial))
					       r))))))
            (else (error-unterminated attr)))))
  (define (error-unterminated attr)
    (error "Unterminated quoted value given for attribute" attr))

  (read-attr input '()))

;; Parses the header value of "Cookie" request header.
;; If cookie version is known by "Cookie2" request header, it should
;; be passed to version (as integer).  Otherwise, it figures out
;; the cookie version from input.
;;
;; Returns the following format.
;;   ((<name> <value> [:path <path>] [:domain <domain>] [:port <port>])
;;    ...)

(define (parse-cookie-string input #!optional version)
  (let ((ver (cond ((integer? version) version)
                   ((string-search "^\\s*\\$Version\\s*=\\s*(\\d+)" input)
                    => (lambda (m)
                         (string->number (cadr m))))
                   (else 0))))
    (let loop ((av-pairs (parse-av-pairs input ver))
               (r '())
               (current '()))
      (cond ((null? av-pairs)
             (if (null? current)
                 (reverse r)
                 (reverse (cons (reverse current) r))))
            ((string-ci=? "$path" (caar av-pairs))
             (loop (cdr av-pairs) r (cons* (cdar av-pairs) path: current)))
            ((string-ci=? "$domain" (caar av-pairs))
             (loop (cdr av-pairs) r (cons* (cdar av-pairs) domain: current)))
            ((string-ci=? "$port" (caar av-pairs))
             (loop (cdr av-pairs) r (cons* (cdar av-pairs) port: current)))
            (else
             (if (null? current)
                 (loop (cdr av-pairs) r (list (cdar av-pairs) (caar av-pairs)))
                 (loop (cdr av-pairs)
                       (cons (reverse current) r)
                       (list (cdar av-pairs) (caar av-pairs)))))))))

;; Construct a cookie string suitable for Set-Cookie or Set-Cookie2 header.
;; specs is the following format.
;;
;;   ((<name> <value> [:comment <comment>] [:comment-url <comment-url>]
;;                    [:discard <bool>] [:domain <domain>]
;;                    [:max-age <age>] [:path <value>] [:port <port-list>]
;;                    [:secure <bool>] [:version <version>] [:expires <date>]
;;    ) ...)
;;
;; Returns a list of cookie strings for each <name>=<value> pair.  In the
;; ``new cookie'' implementation, you can join them by comma and send it
;; at once with Set-cookie2 header.  For the old netscape protocol, you
;; must send each of them by Set-cookie header.


(define (construct-cookie-string specs #!optional (version 1))
  (map (lambda (spec) (construct-cookie-string-1 spec version))
       specs))

(define (construct-cookie-string-1 spec ver)
  (when (< (length spec) 2)
    (error "bad cookie spec: at least <name> and <value> required" spec))
  (let ((name (car spec))
        (value (cadr spec)))
    (let loop ((attr (cddr spec))
               (r    (list (if value
                               (string-append name "="
                                              (quote-if-needed value))
                               name))))
      (define (next s) (loop (cddr attr) (cons s r)))
      (define (ignore) (loop (cddr attr) r))
      (cond
       ((null? attr) (string-join (reverse r) ";"))
       ((null? (cdr attr))
        (error (conc "bad cookie spec: attribute " (car attr) " requires value" )))
       ((eqv? comment: (car attr))
        (if (> ver 0)
	    (next (string-append "Comment=" (quote-if-needed (cadr attr))))
            (ignore)))
       ((eqv? comment-url: (car attr))
        (if (> ver 0)
            (next (string-append "CommentURL=" (quote-value (cadr attr))))
            (ignore)))
       ((eqv? discard: (car attr))
        (if (and (> ver 0) (cadr attr)) (next "Discard") (ignore)))
       ((eqv? domain: (car attr))
        (next (string-append "Domain=" (cadr attr))))
       ((eqv? max-age: (car attr))
        (if (> ver 0)
            (next (sprintf "Max-Age=~a" (cadr attr)))
            (ignore)))
       ((eqv? path: (car attr))
        (next (string-append "Path=" (quote-if-needed (cadr attr)))))
       ((eqv? port: (car attr))
        (if (> ver 0)
            (next (string-append "Port=" (quote-value (cadr attr))))
            (ignore)))
       ((eqv? secure: (car attr))
        (if (cadr attr) (next "Secure") (ignore)))
       ((eqv? version: (car attr))
        (if (> ver 0)
            (next (sprintf "Version=~a" (cadr attr)))
            (ignore)))
       ((eqv? expires: (car attr))
        (if (> ver 0)
            (ignore)
            (next (make-expires-attr (cadr attr)))))
       (else (error "Unknown cookie attribute" (car attr))))
      ))
  )


;; (define (quote-value value)
;;   (string-append "\"" (regexp-replace-all #/\"|\\/ value "\\\\\\0") "\""))

(define (quote-value value)
  (string-append "\"" (string-substitute* value '(("\\\"" . "\\\"") ("\\\\" . "\\\\"))) "\""))

(define quote-if-needed
  (let ((rx (regexp "[\\\",;\\\\ \\t\\n]")))
    (lambda (value)
      (if (string-search rx value)
	  (quote-value value)
	  value))))

(define (make-expires-attr time)
  (sprintf "Expires=~a"
	   (if (number? time)
	       (fmt-time time)
	       time)))

;;;; Added support functions from my utils, split this out

(define (string-search-after r s #!optional (start 0))
  (and-let* ((match-indices (string-search-positions r s start))
	     (right-match (second (first match-indices))))
    (substring s right-match)))

;; Copyright 2007-2008, Matthew Welland.
;; Copyright 2007-2011, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

(declare (unit formdat))
(use regex)
(include "requirements.scm")
(require-extension srfi-69)

(define formdat:*debug* #f)

;; Old data format was something like this. BUT! 
;; Forms do not have names so the hierarcy is
;; unnecessary (I think)
;;
;; hashtable
;;   |-formname --> <formdat> 'form-name=formname
;;   |                        'form-data=hashtable
;;   |                                       | name => value
;;
;; New data format is only the <formdat> portion from above

(define-class <formdat> ()
   (form-data
   ))
;; (define-class <formdat> ()
;;    (form-data
;;    ))
(define (make-formdat:formdat)(vector (make-hash-table)))
(define-inline (formdat:formdat-get-data   vec)    (vector-ref  vec 0))
(define-inline (formdat:formdat-set-data!  vec val)(vector-set! vec 0 val))

(define-method (initialize (self <formdat>) initargs)
(define (formdat:initialize self)
  (call-next-method)
  (slot-set! self 'form-data (make-hash-table))
  (formdat:formdat-set-data! self (make-hash-table)))
  (initialize-slots self initargs))

(define-method (formdat:get (self <formdat>) key)
  (hash-table-ref/default (slot-ref self 'form-data) key #f))
(define (formdat:get self key)
  (hash-table-ref/default (formdat:formdat-get-data self) key #f))

;; change to convert data to list and append val if already exists
;; or is a list
(define-method (formdat:set! (self <formdat>) key val)
(define (formdat:set! self key val)
  (let ((prev-val (formdat:get self key))
        (ht       (slot-ref self 'form-data)))
        (ht       (formdat:formdat-get-data self)))
    (if prev-val
        (if (list? prev-val)
            (hash-table-set! ht key (cons val prev-val))
            (hash-table-set! ht key (list val prev-val)))
        (hash-table-set! ht key val))
    self))

(define-method (formdat:keys (self <formdat>))
  (hash-table-keys (slot-ref self 'form-data)))
(define (formdat:keys self)
  (hash-table-keys (formdat:formdat-get-data self)))

(define-method (formdat:printall (self <formdat>) printproc)
(define (formdat:printall self printproc)
  (printproc "formdat:printall " (formdat:keys self))
  (for-each (lambda (k)
	      (printproc k " => " (formdat:get self k)))
	    (formdat:keys self)))

(define-method (formdat:all->strings (self <formdat>))
(define (formdat:all->strings self)
  (let ((res '()))
    (for-each (lambda (k)
                 (set! res (cons (conc k "=>" (formdat:get self k)) res)))
              (formdat:keys self))
        res))

;; call with *one* of the lists in the list of lists created by CGI:url-unquote
(define-method (formdat:load (self <formdat>) formlist)
  (let ((ht             (slot-ref self 'form-data)))
(define (formdat:load self formlist)
  (let ((ht             (formdat:formdat-get-data self)))
    (if (null? formlist) self ;; no values provided, return self for no good reason
        (let loop ((head (car formlist))
                   (tail (cdr formlist)))
          (let ((key (car head))
                (val (cdr head)))
            ;; (err:log "key=" key " val=" val)
	    (if (> (length val) 1)

(define formdat:bin-data-name-rex (regexp "\\Wname=\"([^\"]+)\""))
(define formdat:bin-file-name-rex (regexp "\\Wfilename=\"([^\"]+)\""))
(define formdat:bin-file-type-rex (regexp "Content-Type:\\s+([^\\s]+)"))
(define formdat:delim-patt-rex    (regexp "^\\-+[0-9]+\\-*$"))

;; returns a hash with entries for all forms - could well use a proplist?
(define (formdat:load-all)
  (let ((request-method (getenv "REQUEST_METHOD")))
  (let ((request-method (get-environment-variable "REQUEST_METHOD")))
    (if (and request-method
	     (string=? request-method "POST"))
	(formdat:load-all-port (current-input-port)))))

;; (s:process-cgi-input (caaar dat))
(define (formdat:load-all-port inp)
  (let* ((formdat        (make <formdat>)))
  (let* ((formdat        (make-formdat:formdat)))
;;	 (debugp         (open-output-file (conc (slot-ref s:session 'sroot) "/delme-" (current-user-id) ".log"))))
    ;; (write-string (read-string #f inp) #f debugp)
    (let ((alldats (formdat:dat->list inp 10e6)))
      
      ;; (format debugp "formdat : alldats: ~A\n" alldats)
      (let ((firstitem   (car alldats))
	    (multipass #f)) 

;; Copyright 2007-2008, Matthew Welland.
;; Copyright 2007-2011, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

(declare (unit html-filter))
(require-extension regex)

;; 
(define (s:split-string strng delim)
  (if (eq? (string-length strng) 0) (list strng)
      (let loop ((head (make-string 1 (car (string->list strng))))
		 (tail (cdr (string->list strng)))
		 (dest '())

;; Copyright 2007-2008, Matthew Welland.
;; Copyright 2007-2011, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

;;======================================================================
;; The meta data key store, just a general dumping ground for values
;; only used occasionally
;;======================================================================

(declare (unit keystore))

(define (keystore:get db key)
  (dbi:get-one db "SELECT value FROM metadata WHERE key=?;" key))

(define (keystore:set! db key value)
  (let ((curr-val (keystore:get db key)))
    (if curr-val

;; Copyright 2007-2008, Matthew Welland.
;; Copyright 2007-2011, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

;;======================================================================
;; dumbobj helpers
;;======================================================================

(declare (unit misc-stml))
(use regex)

;; given a list of symbols give the count of the matching symbol
;; l => '(a b c)  (dumobj:indx a 'b) => 1
(define (s:get-fieldnum lst field-name)
  (let loop ((head (car lst))
             (tail (cdr lst))
             (fnum 0))

		   (s:html (s:head 
			    (s:title err)
			    (s:body
			     (s:h1 "ERROR")
			     (s:p err)))))))

(define (s:validate-uri)
  (let ((uri (getenv "REQUEST_URI"))
	(qrs (getenv "QUERY_STRING")))
  (let ((uri (get-environment-variable "REQUEST_URI"))
	(qrs (get-environment-variable "QUERY_STRING")))
    (if (not uri)
	(set! uri qrs))
    (if uri
	(string-match 
	 (regexp "^(/[a-z\\-\\._:0-9]*)*(|\\?([A-Za-z0-9_\\-\\+]+=[A-Za-z0-9_\\-\\.\\+]*&{0,1})*)$") uri)
	(begin
	  (s:log "REQUEST URI NOT AVAILABLE!")
	  (let ((p (open-input-pipe "env")))
	    (let loop ((l (read-line p))
		       (res '()))
	      (if (eof-object? l)
		  (s:log res)
		  (loop (read-line p)(cons (list l "<BR>") res)))))
	  #t))))

(define (s:validate-inputs)
  (if (not (s:validate-uri))(begin (s:error-page "Bad URI" (let ((ref (getenv "HTTP_REFERER")))
  (if (not (s:validate-uri))(begin (s:error-page "Bad URI" (let ((ref (get-environment-variable "HTTP_REFERER")))
							     (if ref
								 (list "referred from" ref)
								 "")))
				   (exit))))

;; anything except a list is converted to a string!!!
(define (s:any->string val)

;; Copyright 2007-2010, Matthew Welland.
;;
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;;
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

;; twiki module
(require-extension sqlite3 regex posix md5 base64)
(import (prefix base64 base64:))

;; TODO
;;
;; * Inline tiddlers [inline[TiddlerName]]
;; * Pics            [pic X Y[picname.jpg]]
;; * Move twiki parsing/expanding to mattsutils as loadable module

;; This is the currently supported mechanism. Postgres will be added later -mrw- 7/26/2009
;;
(define (twiki:open-db key . create-not-ok)
  ;; (s:log "Got to twiki:open-db with key: " key)
  (let* ((create-ok (if (null? create-not-ok) #t (car create-not-ok)))
	 (fdat      (twiki:key->fname key))
	 (basepath  (slot-ref s:session 'twikidir))
	 (basepath  (sdat-get-twikidir s:session))
	 (fpath     (car fdat))
	 (fname     (cadr fdat))
	 (fullname  (conc basepath "/" fpath "/" fname))
	 (fexists   (file-exists? fullname))
	 (db        (if fexists (dbi:open 'sqlite3 (list (cons 'dbname fullname))) #f)))
    (if (and (not db)
	     (not create-ok))
	(exit 100)
	(begin
	  (if (not fexists)
	      (begin
		;; (print "fullname: " fullname)
		(twiki:register-wiki key fullname)
		(system (conc "mkdir -p " fpath)) ;; create the path
		(if (file-exists? fpath)
		    (s:log "OK: dir " fpath " has been made")
		    (s:log "ERROR: Failed to make the path for the twiki"))
		(set! db (dbi:open 'sqlite3 (list (cons 'dbname fullname))))
		(for-each 
		 (lambda (sqry)
		   ;; (print sqry)
		   (dbi:exec db sqry))
		 ;; types: 0 text, 1 jpg, 2 png, 3 svg, 4 spreadsheet, 5 audio, 6 video :: better specs to come...
		 (list

		  "CREATE TABLE members  (id INTEGER PRIMARY KEY,person_id INTEGER,group_id INTEGER);"
		  ;; setup and configuration data
		  "CREATE TABLE meta     (id INTEGER PRIMARY KEY,key TEXT,val TEXT);"
		  ;; need to create an entry for *this* twiki
		  (conc "INSERT INTO wikis (id,name,created_on) VALUES (1,'main'," (current-seconds) ");")))
		;;     (conc "INSERT INTO tiddlers (wiki_id,name,created_on) VALUES(1,'MainMenu'," (current-seconds) ");")))))
		(twiki:save-tiddler db "MainMenu" "[[FirstTiddler]]" "" 1 1)))
	  (sqlite3:set-busy-timeout!(dbi:db-conn db) 1000000)
	  ;; (sqlite3:set-busy-timeout!(dbi:db-conn db) 1000000)
	  db))))

;;======================================================================
;; twikis (db naming, sqlite vs postgresql, keys etc.
;;======================================================================

;; A wiki is specified by a list of keys, here we convert that list to a single string

	 (p1         (substring keypath 0           delta)) ;;  0  8))
	 (p2         (substring keypath delta       (* delta 2)));;  8 16))
	 (p3         (substring keypath (* delta 2) (* delta 3)))) ;; 16 24))
    (list (string-intersperse (list "twikis" p1 p2 p3) "/") keypath)))

;; look up the wid based on the keys, this is used for sub wikis only. I.e. a wiki instantiated inside another wiki 
;; giving a separate namespace to all the tiddlers
(define (twiki:name->wid db name) ;; (slot-ref s:session 'conn)
(define (twiki:name->wid db name) 
  (let ((wid (dbi:get-one db "SELECT id FROM wikis WHERE name=?;" name)))
    (if wid wid
	(begin
	  (dbi:exec db "INSERT INTO wikis (name,created_on) VALUES(?,?);" name (current-seconds))
	  (twiki:name->wid db name)))))

;;======================================================================

;;======================================================================
;; twiki registry
;;======================================================================

;; these can be overridden by end user (just create a new routine by the same name)

(define (twiki:open-registry)
  (let* ((basepath  (slot-ref s:session 'sroot))
  (let* ((basepath  (sdat-get-sroot s:session))
	 (regfile   (conc basepath "/twikis/registry.db"))
	 (regexists (file-exists? regfile))
	 (db        (dbi:open 'sqlite3 (list (cons 'dbname regfile)))))
    (if regexists
	db
	(begin
	  (for-each (lambda (stmt)(dbi:exec db stmt))

	    (s:a "delete" 'href (s:link-to (twiki:get-link-back-to-current) 'delete_tiddler tnum))(s:br)
	    (s:input-preserve 'type "text" 'name "twiki_title" 'size "58" 'maxlength "150")
	    (s:textarea-preserve 'type "textarea" 'name "twiki_body" 'rows "10" 'cols "65")
	    (s:p "Tags" (s:input-preserve 'type "text" 'name "twiki_tags" 'size "55" 'maxlength "150")))))

;; save a tiddler to the db for the twiki twik, getting data from the INPUT
(define (twiki:save-curr-tiddler tdb wid)
  (formdat:printall (slot-ref s:session 'formdat) s:log)
  (formdat:printall (sdat-get-formdat s:session) s:log)
  (let* ((heading (s:get-input 'twiki_title))
	 (body    (s:get-input 'twiki_body))
	 (tags    (s:get-input 'twiki_tags))
	 (uid     (twiki:get-id)))
    ;; (s:log "twiki:save-curr-tiddler heading: " heading " body: " body " tags: " tags)
    (s:set! 'twiki_title heading)
    (if body

			"INSERT INTO tiddlers (wiki_id,name,dat_id,created_on,owner_id) VALUES(?,?,?,?,?);"
			wid heading dat-id (current-seconds) uid))
	  #t) ;; success
	#f))  ;; non-success

;; text=0, jpg=1, png=2
(define (twiki:save-dat db dat type)
  (let* ((md5sum (md5:digest dat))
  (let* ((md5sum (md5-digest dat))
	 (datid  (twiki:dat-exists? db md5sum type))
	 (datblob (if (string? dat)
		      (string->blob dat)
		      dat)))
    (if datid
	datid
	(begin

(define (twiki:get-thumb-dat tdb wid pic-id)
  (dbi:get-one tdb "SELECT dat FROM pics INNER JOIN dats ON pics.thumb_dat_id=dats.id WHERE pics.id=? AND wiki_id=?;" pic-id wid))

;; this one sets up the Content type, puts the data into page-dat and is done
(define (twiki:return-image-dat tdb wid pic-id)
  (let ((dat  (twiki:get-pic-dat tdb wid pic-id)))
    (s:log "twiki:return-image-dat dat is: " dat " of size: " (if (blob? dat)(blob-size dat) "[not a blob]"))
    (slot-set! s:session 'page-type 'image)
    (slot-set! s:session 'content-type "image/jpeg")
    (slot-set! s:session 'alt-page-dat dat)))
    (sdat-set-page-type!    s:session 'image)
    (sdat-set-content-type! s:session "image/jpeg")
    (sdat-set-alt-page-dat! s:session dat)))
    ;; (session:alt-out s:session)))

;; this one sets up the Content type, puts the data into page-dat and is done
(define (twiki:return-thumb-dat tdb wid pic-id)
  (let ((dat  (twiki:get-thumb-dat tdb wid pic-id)))
    (s:log "twiki:return-image-dat dat is: " dat " of size: " (if (blob? dat)(blob-size dat) "[not a blob]"))
    (slot-set! s:session 'page-type 'image)
    (slot-set! s:session 'content-type "image/jpeg")
    (slot-set! s:session 'alt-page-dat dat)))
    (sdat-set-page-type!    s:session 'image)
    (sdat-set-content-type! s:session "image/jpeg")
    (sdat-set-alt-page-dat! s:session dat)))
    ;; (session:alt-out s:session)))
  
(define (twiki:make-thumbnail tdb pic-id wid)
  (let ((indat  (twiki:get-pic-dat tdb wid pic-id)))
    ;;   (outdat (open-output-string)))
    (let-values (((inp oup pid)(process "convert" (list "-size" "500x180" "-" "-thumbnail" "250x90" "-unsharp" "0x.5" "-"))))
		(write-string (blob->string indat) #f oup)

    (dbi:close tdb)
    result))

;; should do a single more efficient query but this is good enough
(define (twiki:get-tiddlers db wid tnames)
  (apply twiki:get-tiddlers-by-name db wid tnames))
;;   (let* ((tdlrs '())
;; 	 ;; (conn   (slot-ref s:session 'conn))
;; 	 ;; (conn   (sdat-get-conn s:session))
;; 	 (namelst (conc "('" (string-intersperse (map conc tnames) "','") "')"))
;; 	 (qry     (conc twiki:tiddler-selector " WHERE t.wiki_id=? AND t.id IN " namelst ";")))
;;     ;; (print qry)
;;     (dbi:for-each-row
;;      (lambda (row)
;;        (set! tdlrs (cons row tdlrs)))
;;      db qry wid)
;;     (reverse tdlrs))) ;; !Twiki\

;; tlst is a list of tiddler nums
(define (twiki:get-tiddlers-by-num db wid tlst)
  ;; (s:log "Got to twiki:get-tiddlers with keys: " tlst " and wid: " wid)
  ;; select where created_on < somedate order by created_on desc limit 1
  (let* ((tdlrs '())
	 (tlststr (string-intersperse (map number->string tlst) ","))
	 (already-got (make-hash-table))
	 (qry    (conc twiki:tiddler-selector " WHERE t.wiki_id=? AND t.id IN (" tlststr ") ORDER BY created_on DESC;")))
	;; (conn   (slot-ref s:session 'conn))
    ;; (print "qry: " qry)
    (dbi:for-each-row
     (lambda (row)
       (let ((tname (twiki:tiddler-get-name row)))
	 (if (not (hash-table-ref/default already-got tname #f))
	     (begin
	       (set! tdlrs (cons row tdlrs))
	       (hash-table-set! already-got tname #t)))))

(define twiki:u          s:u)
(define twiki:td         s:td)
(define twiki:tr         s:tr)
(define twiki:table      s:table)
(define twiki:div        s:div)

(define (twiki:web64enc str)
  (string-substitute "=" "_" (base64:encode str) #t))
  (string-substitute "=" "_" (base64:base64-encode str) #t))

(define (twiki:web64dec str)
  (base64:decode (string-substitute "_" "=" str #t)))
  (base64:base64-decode (string-substitute "_" "=" str #t)))
    
(define (twiki:make-tlink text tiddlername)
  (s:a text 'href (s:link-to (twiki:get-link-back-to-current) 'view_tiddler (twiki:web64enc tiddlername))))

(define (twiki:pic pic-name size wiki)
  (let* ((tdb    (twiki:wiki-get-dbh wiki))
	 (tkey   (twiki:wiki-get-key wiki))

;; Copyright 2007-2008, Matthew Welland.
;; Copyright 2007-2011, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

(declare (unit session))
(include "requirements.scm")
(require-library dbi)
(require-extension regex)
(declare (uses cookie))

;; sessions table
;; id session_id session_key
;; create table sessions (id serial not null,session-key text);

;; session_vars table
;; id session_id page_id key value
;; create table session_vars (id serial not null,session_id integer,page text,key text,value text);

;; TODO
;;  Concept of order num incremented with each page access
;;     if a branch is taken then a new session would need to be created
;;

;; make-vector-record session session dbtype dbinit conn params path-params session-key session-id domain toppage page curr-page content-type page-type sroot twikidir pagedat alt-page-dat pagevars pagevars-before sessionvars sessionvars-before globalvars globalvars-before logpt formdat request-method session-cookie curr-err log-port logfile seen-pages page-dir-style debugmode
(define-class <session> ()
  (dbtype       ;; 'pg or 'sqlite3
   dbinit
   conn
   params       ;; params from the key=val&key1=val2 string
   path-params  ;; remaining params from the path
   session-key
   session-id
   domain
   toppage      ;; defaults to "index" - override in .stml.config if desired
   page         ;; the page name - defaults to home
   curr-page    ;; the current page being evaluated
   content-type ;; the default content type is text/html, override to deliver other stuff
   page-type    ;; use in conjunction with content-type to deliver other payloads
   sroot
   twikidir     ;; location for twikis - needs to be fully writable by web server
   pagedat
   alt-page-dat
   pagevars     ;; session vars specific to this page
   pagevars-before
   sessionvars  ;; session vars visible to all pages
   sessionvars-before
   globalvars   ;; global vars visible to all sessions
   globalvars-before
   logpt
   formdat
   request-method
   session-cookie
   curr-err
   log-port
   logfile
   seen-pages
   page-dir-style  ;; #t = new style, #f = old style
   debugmode))
(define (make-sdat)(make-vector 33))
(define (sdat-get-dbtype               vec)    (vector-ref  vec 0))
(define (sdat-get-dbinit               vec)    (vector-ref  vec 1))
(define (sdat-get-conn                 vec)    (vector-ref  vec 2))
(define (sdat-get-params               vec)    (vector-ref  vec 3))
(define (sdat-get-path-params          vec)    (vector-ref  vec 4))
(define (sdat-get-session-key          vec)    (vector-ref  vec 5))
(define (sdat-get-session-id           vec)    (vector-ref  vec 6))
(define (sdat-get-domain               vec)    (vector-ref  vec 7))
(define (sdat-get-toppage              vec)    (vector-ref  vec 8))
(define (sdat-get-page                 vec)    (vector-ref  vec 9))
(define (sdat-get-curr-page            vec)    (vector-ref  vec 10))
(define (sdat-get-content-type         vec)    (vector-ref  vec 11))
(define (sdat-get-page-type            vec)    (vector-ref  vec 12))
(define (sdat-get-sroot                vec)    (vector-ref  vec 13))
(define (sdat-get-twikidir             vec)    (vector-ref  vec 14))
(define (sdat-get-pagedat              vec)    (vector-ref  vec 15))
(define (sdat-get-alt-page-dat         vec)    (vector-ref  vec 16))
(define (sdat-get-pagevars             vec)    (vector-ref  vec 17))
(define (sdat-get-pagevars-before      vec)    (vector-ref  vec 18))
(define (sdat-get-sessionvars          vec)    (vector-ref  vec 19))
(define (sdat-get-sessionvars-before   vec)    (vector-ref  vec 20))
(define (sdat-get-globalvars           vec)    (vector-ref  vec 21))
(define (sdat-get-globalvars-before    vec)    (vector-ref  vec 22))
(define (sdat-get-logpt                vec)    (vector-ref  vec 23))
(define (sdat-get-formdat              vec)    (vector-ref  vec 24))
(define (sdat-get-request-method       vec)    (vector-ref  vec 25))
(define (sdat-get-session-cookie       vec)    (vector-ref  vec 26))
(define (sdat-get-curr-err             vec)    (vector-ref  vec 27))
(define (sdat-get-log-port             vec)    (vector-ref  vec 28))
(define (sdat-get-logfile              vec)    (vector-ref  vec 29))
(define (sdat-get-seen-pages           vec)    (vector-ref  vec 30))
(define (sdat-get-page-dir-style       vec)    (vector-ref  vec 31))
(define (sdat-get-debugmode            vec)    (vector-ref  vec 32))
(define (sdat-set-dbtype!              vec val)(vector-set! vec 0 val))
(define (sdat-set-dbinit!              vec val)(vector-set! vec 1 val))
(define (sdat-set-conn!                vec val)(vector-set! vec 2 val))
(define (sdat-set-params!              vec val)(vector-set! vec 3 val))
(define (sdat-set-path-params!         vec val)(vector-set! vec 4 val))
(define (sdat-set-session-key!         vec val)(vector-set! vec 5 val))
(define (sdat-set-session-id!          vec val)(vector-set! vec 6 val))
(define (sdat-set-domain!              vec val)(vector-set! vec 7 val))
(define (sdat-set-toppage!             vec val)(vector-set! vec 8 val))
(define (sdat-set-page!                vec val)(vector-set! vec 9 val))
(define (sdat-set-curr-page!           vec val)(vector-set! vec 10 val))
(define (sdat-set-content-type!        vec val)(vector-set! vec 11 val))
(define (sdat-set-page-type!           vec val)(vector-set! vec 12 val))
(define (sdat-set-sroot!               vec val)(vector-set! vec 13 val))
(define (sdat-set-twikidir!            vec val)(vector-set! vec 14 val))
(define (sdat-set-pagedat!             vec val)(vector-set! vec 15 val))
(define (sdat-set-alt-page-dat!        vec val)(vector-set! vec 16 val))
(define (sdat-set-pagevars!            vec val)(vector-set! vec 17 val))
(define (sdat-set-pagevars-before!     vec val)(vector-set! vec 18 val))
(define (sdat-set-sessionvars!         vec val)(vector-set! vec 19 val))
(define (sdat-set-sessionvars-before!  vec val)(vector-set! vec 20 val))
(define (sdat-set-globalvars!          vec val)(vector-set! vec 21 val))
(define (sdat-set-globalvars-before!   vec val)(vector-set! vec 22 val))
(define (sdat-set-logpt!               vec val)(vector-set! vec 23 val))
(define (sdat-set-formdat!             vec val)(vector-set! vec 24 val))
(define (sdat-set-request-method!      vec val)(vector-set! vec 25 val))
(define (sdat-set-session-cookie!      vec val)(vector-set! vec 26 val))
(define (sdat-set-curr-err!            vec val)(vector-set! vec 27 val))
(define (sdat-set-log-port!            vec val)(vector-set! vec 28 val))
(define (sdat-set-logfile!             vec val)(vector-set! vec 29 val))
(define (sdat-set-seen-pages!          vec val)(vector-set! vec 30 val))
(define (sdat-set-page-dir-style!      vec val)(vector-set! vec 31 val))
(define (sdat-set-debugmode!           vec val)(vector-set! vec 32 val))

;; (define-class <session> ()
;;   (dbtype       ;; 'pg or 'sqlite3
;;    dbinit
;;    conn
;;    params       ;; params from the key=val&key1=val2 string
;;    path-params  ;; remaining params from the path
;;    session-key
;;    session-id
;;    domain
;;    toppage      ;; defaults to "index" - override in .stml.config if desired
;;    page         ;; the page name - defaults to home
;;    curr-page    ;; the current page being evaluated
;;    content-type ;; the default content type is text/html, override to deliver other stuff
;;    page-type    ;; use in conjunction with content-type to deliver other payloads
;;    sroot
;;    twikidir     ;; location for twikis - needs to be fully writable by web server
;;    pagedat
;;    alt-page-dat
;;    pagevars     ;; session vars specific to this page
;;    pagevars-before
;;    sessionvars  ;; session vars visible to all pages
;;    sessionvars-before
;;    globalvars   ;; global vars visible to all sessions
;;    globalvars-before
;;    logpt
;;    formdat
;;    request-method
;;    session-cookie
;;    curr-err
;;    log-port
;;    logfile
;;    seen-pages
;;    page-dir-style  ;; #t = new style, #f = old style
;;    debugmode))

;; SPLIT INTO STRAIGHT FORWARD INIT AND COMPLEX INIT
(define-method (initialize (self <session>) initargs)
(define (session:initialize self)
  (call-next-method)
  (slot-set! self 'dbtype      'pg)
  (slot-set! self 'page        "home")        ;; these are defaults
  (slot-set! self 'curr-page   "home")
  (slot-set! self 'content-type "Content-type: text/html; charset=iso-8859-1\n\n")
  (slot-set! self 'page-type   'html)
  (slot-set! self 'toppage     "index")
  (slot-set! self 'params      '())           ;;
  (slot-set! self 'path-params '())
  (slot-set! self 'session-key #f)
  (slot-set! self 'pagedat     '())
  (slot-set! self 'alt-page-dat #f)
  (slot-set! self 'sroot       "./")
  (slot-set! self 'session-cookie #f)
  (slot-set! self 'curr-err #f)
  (slot-set! self 'log-port (current-error-port))
  (slot-set! self 'seen-pages '())
  (slot-set! self 'page-dir-style #t) ;; #t : pages/<pagename>_(view|cntl).scm
  (sdat-set-dbtype! self      'pg)
  (sdat-set-page! self        "home")        ;; these are defaults
  (sdat-set-curr-page! self   "home")
  (sdat-set-content-type! self "Content-type: text/html; charset=iso-8859-1\n\n")
  (sdat-set-page-type! self   'html)
  (sdat-set-toppage! self     "index")
  (sdat-set-params! self      '())           ;;
  (sdat-set-path-params! self '())
  (sdat-set-session-key! self #f)
  (sdat-set-pagedat! self     '())
  (sdat-set-alt-page-dat! self #f)
  (sdat-set-sroot! self       "./")
  (sdat-set-session-cookie! self #f)
  (sdat-set-curr-err! self #f)
  (sdat-set-log-port! self (current-error-port))
  (sdat-set-seen-pages! self '())
  (sdat-set-page-dir-style! self #t) ;; #t : pages/<pagename>_(view|cntl).scm
                                      ;; #f : pages/<pagename>/(view|control).scm 
  (slot-set! self 'debugmode #f)
  (for-each (lambda (slot-name)
              (slot-set! self slot-name (make-hash-table)))
            (list 'pagevars 'sessionvars 'globalvars 'pagevars-before 
		  'sessionvars-before 'globalvars-before))
  (slot-set! self 'domain "locahost")   ;; end of defaults
  (initialize-slots self (session:read-config self))
  ;; some values read in from the config file need to be evaled
  (sdat-set-debugmode!          self #f)
  			     
  (sdat-set-pagevars!           self (make-hash-table))
  (sdat-set-sessionvars!        self (make-hash-table))
  (sdat-set-globalvars!         self (make-hash-table))
  (sdat-set-pagevars-before!    self (make-hash-table))
  (sdat-set-sessionvars-before! self (make-hash-table))
  (sdat-set-globalvars-before!  self (make-hash-table))
  (sdat-set-domain!             self "locahost")   ;; end of defaults
  (let* ((rawconfigdat (session:read-config self))
	 (configdat (if rawconfigdat (eval rawconfigdat) '()))
	 (sroot     (s:find-param 'sroot    configdat))
  (for-each (lambda (slot-name)
	      (slot-set! self slot-name (eval (slot-ref self slot-name))))
	    (list 'dbtype))
  (initialize-slots self initargs))

(define-method (session:setup (self <session>))
  (let ((dbtype (slot-ref self 'dbtype))
	(dbinit (eval (slot-ref self 'dbinit)))
	 (logfile   (s:find-param 'logfile  configdat))
	 (dbtype    (s:find-param 'dbtype   configdat))
	 (dbinit    (s:find-param 'dbinit   configdat))
	 (domain    (s:find-param 'domain   configdat))
	 (twikidir  (s:find-param 'twikidir configdat))
	 (page-dir  (s:find-param 'page-dir-style configdat)))
    (if sroot    (sdat-set-sroot!    self sroot))
    (if logfile  (sdat-set-logfile!  self logfile))
    (if dbtype   (sdat-set-dbtype!   self dbtype))
    (if dbinit   (sdat-set-dbinit!   self dbinit))
    (if domain   (sdat-set-domain!   self domain))
    (if twikidir (sdat-set-twikidir! self twikidir))
    (sdat-set-page-dir-style! self page-dir)
    ;; (print "configdat: ")(pp configdat)
    ;;(session:log self "sroot: " sroot " logfile: " logfile " dbtype: " dbtype 
    ;;		 " dbinit: " dbinit " domain: " domain " page-dir-style: " page-dir)
    )
  )
;;   (let ((dbtype (sdat-get-dbtype self)))
;;     (print "dbtype: " dbtype)
;;     (sdat-set-dbtype! self (eval dbtype))))

(define (session:setup self)
  (let ((dbtype (sdat-get-dbtype self))
	(dbinit (eval (sdat-get-dbinit self)))
	(dbexists #f))
    (let ((dbfname (alist-ref 'dbname dbinit)))
      (if (eq? dbtype 'sqlite3)
	  (if (file-exists? dbfname)
	      (begin
		;; (session:log self "setting dbexists to #t")
		(set! dbexists #t))))
      ;; (session:log self "dbtype: " dbtype " dbfname: " dbfname " dbexists: " dbexists))
      )
    (slot-set! self 'conn (dbi:open dbtype dbinit))
    (sdat-set-conn! self (dbi:open dbtype dbinit))
    (if (and (not dbexists)(eq? dbtype 'sqlite3))
 	(begin
	  (print "WARNING: Setting up session db with sqlite3")
	  (session:setup-db self)))
    (session:process-url-path self)
    (session:setup-session-key self)
    ;; capture stdin if this is a POST
    (slot-set! self 'request-method (getenv "REQUEST_METHOD"))
    (slot-set! self 'formdat (formdat:load-all))))
    (sdat-set-request-method! self (get-environment-variable "REQUEST_METHOD"))
    (sdat-set-formdat! self (formdat:load-all))))

;; setup the db with session tables, works for sqlite only right now
(define-method (session:setup-db (self <session>))
  (let ((conn (slot-ref self 'conn)))
(define (session:setup-db self)
  (let ((conn (sdat-get-conn self)))
    (for-each 
     (lambda (stmt)
       (dbi:exec conn stmt))
     (list "CREATE TABLE session_vars (id INTEGER PRIMARY KEY,session_id INTEGER,page TEXT,key TEXT,value TEXT);"
	   "CREATE TABLE sessions (id INTEGER PRIMARY KEY,session_key TEXT,last_used TIMESTAMP);"
           "CREATE TABLE metadata (id INTEGER PRIMARY KEY,key TEXT,value TEXT);"))))
;;  ;; if we have a session_key look up the session-id and store it
;;  (slot-set! self 'session-id (session:get-id self)))
;;  (sdat-set-session-id! self (session:get-id self)))

;; only set session-cookie when a new session is created
(define-method (session:setup-session-key (self <session>))  
(define (session:setup-session-key self)  
  (let* ((sk  (session:extract-session-key self))
         (sid (if sk (session:get-id self sk) #f)))
    (if (not sid) ;; need a new key
        (let* ((new-key (session:get-new-key self))
               (new-sid (session:get-id self new-key)))
          (slot-set! self 'session-key new-key)
          (slot-set! self 'session-id new-sid)
          (slot-set! self 'session-cookie (session:make-cookie self)))
        (slot-set! self 'session-id sid))))
          (sdat-set-session-key! self new-key)
          (sdat-set-session-id! self new-sid)
          (sdat-set-session-cookie! self (session:make-cookie self)))
        (sdat-set-session-id! self sid))))

(define-method (session:make-cookie (self <session>))
  ;; (list (conc "session_key=" (slot-ref self 'session-key) "; Path=/; Domain=." (slot-ref self 'domain) "; Max-Age=" (* 86400 14) "; Version=1"))) 
(define (session:make-cookie self)
  ;; (list (conc "session_key=" (sdat-get-session-key self) "; Path=/; Domain=." (sdat-get-domain self) "; Max-Age=" (* 86400 14) "; Version=1"))) 
  (list (string-substitute 
	 ";" "; " 
	 (car (construct-cookie-string 
	       ;; warning! messing up this itty bitty bit of code will cost much time!
	       `(("session_key" ,(slot-ref self 'session-key)
	       `(("session_key" ,(sdat-get-session-key self)
		  expires: ,(+ (current-seconds) (* 14 86400)) 
		  max-age: (* 14 86400)
		  path: "/" ;; 
		  domain: ,(string-append "." (slot-ref self 'domain))
		  domain: ,(string-append "." (sdat-get-domain self))
		  version: 1)) 0)))))

;; look up a given session key and return the id if found, #f if not found
(define-method (session:get-id (self <session>) session-key)
  ;; (let ((session-key (slot-ref self 'session-key)))
(define (session:get-id self session-key)
  ;; (let ((session-key (sdat-get-session-key self)))
  (if session-key
      (let ((query (string-append "SELECT id FROM sessions WHERE session_key='" session-key "'"))
            (conn (slot-ref self 'conn))
            (conn (sdat-get-conn self))
            (result #f))
	(dbi:for-each-row 
	 (lambda (tuple)
	   (set! result (vector-ref tuple 0)))
	 conn query)
	(if result (dbi:exec conn (conc "UPDATE sessions SET last_used=" (dbi:now conn) " WHERE session_key=?;") session-key))
        result)
      #f))

;; 
(define-method (session:process-url-path (self <session>))
  (let ((path-info    (getenv "PATH_INFO"))
	(query-string (getenv "QUERY_STRING")))
(define (session:process-url-path self)
  (let ((path-info    (get-environment-variable "PATH_INFO"))
	(query-string (get-environment-variable "QUERY_STRING")))
    ;; (session:log self "path-info=" path-info " query-string=" query-string)
    (if path-info
	(let* ((parts    (string-split path-info "/"))
	       (numparts (length parts)))
	  (if (> numparts 0)
	      (slot-set! self 'page (car parts)))
	      (sdat-set-page! self (car parts)))
	  ;; (session:log self "url-path=" url-path " parts=" parts)
	  (if (> numparts 1)
	      (slot-set! self 'path-params (cdr parts)))
	      (sdat-set-path-params! self (cdr parts)))
          (if query-string
              (slot-set! self 'params (string-split query-string "&")))))))
              (sdat-set-params! self (string-split query-string "&")))))))

;; BUGGY!
(define-method (session:get-new-key (self <session>))
  (let ((conn   (slot-ref self 'conn))
(define (session:get-new-key self)
  (let ((conn   (sdat-get-conn self))
        (tmpkey (session:make-rand-string 20))
        (status #f))
    (dbi:for-each-row (lambda (tuple)
			(set! status #t))
		      conn (string-append "INSERT INTO sessions (session_key) VALUES ('" tmpkey "')"))
    tmpkey))

;; returns session key IFF it is in the HTTP_COOKIE 
(define-method (session:extract-session-key (self <session>))
  (let ((http-session (getenv "HTTP_COOKIE")))
(define (session:extract-session-key self)
  (let ((http-session (get-environment-variable "HTTP_COOKIE")))
    (if http-session 
        (session:extract-key-from-param self (list http-session) "session_key")
        #f)))

(define-method (session:get-session-id (self <session>) session-key)
(define (session:get-session-id self session-key)
  (let ((query "SELECT id FROM sessions WHERE session_key=?;")
        (result #f))
    ;;     (pg:query-for-each (lambda (tuple)
    ;;                          (set! result (vector-ref tuple 0))) ;; (vector-ref tuple 0)))
    ;;                        (s:sqlparam query session-key)
    ;;                        (slot-ref self 'conn))
    ;;                        (sdat-get-conn self))
    ;;                        conn)
    (dbi:for-each-row (lambda (tuple)
			(set! result (vector-ref tuple 0))) ;; (vector-ref tuple 0)))
		      (slot-ref self 'conn)
		      (sdat-get-conn self)
		      (s:sqlparam query session-key))
    result))

;; delete all records for a session
;;
(define-method (session:delete-session (self <session>) session-key)
(define (session:delete-session self session-key)
  (let ((session-id (session:get-session-id self session-key))
        (qry        (conc "BEGIN;"
			  "DELETE FROM session_vars WHERE session_id=?;"
                          "DELETE FROM sessions WHERE id=?;"
			  "COMMIT;"))
        (conn              (slot-ref self 'conn)))
        (conn              (sdat-get-conn self)))
    (if session-id
        (begin
          (dbi:exec conn qry session-id session-id)
	  (initialize self '())
	  (session:initialize self)
	  (session:setup self)))
    (not (session:get-session-id self session-key))))

;; (define-method (session:delete-session (self <session>) session-key)
;; (define (session:delete-session self session-key)
;;   (let ((session-id (session:get-session-id self session-key))
;;         (queries    (list "BEGIN;"
;; 			  "DELETE FROM session_vars WHERE session_id=?;"
;;                           "DELETE FROM sessions WHERE id=?;"
;; 			  "COMMIT;"))
;;         (conn              (slot-ref self 'conn)))
;;         (conn              (sdat-get-conn self)))
;;     (if session-id
;;         (begin
;;           (for-each
;;            (lambda (query)
;;              (dbi:exec conn query session-id))
;; 	   queries)
;; 	  (initialize self '())
;; 	  (session:setup self)))
;;     (not (session:get-session-id self session-key))))

(define-method (session:extract-key (self <session>) key)
  (let ((params (slot-ref self 'params)))
(define (session:extract-key self key)
  (let ((params (sdat-get-params self)))
    (session:extract-key-from-param self params key)))

(define-method (session:extract-key-from-param (self <session>) params key)
(define (session:extract-key-from-param self params key)
  (let ((r1     (regexp (string-append "^" key "=([^=]+)$"))))
    (if (< (length params) 1) #f
	(let loop ((head   (car params))
		   (tail   (cdr params)))
	  (let ((match (string-match r1 head)))
	    (cond
	     (match
	      (let ((session-key (list-ref match 1)))
		(slot-set! self 'session-key (list-ref match 1))
		(sdat-set-session-key! self (list-ref match 1))
		session-key))
	     ((null? tail)
	      #f)
	     (else
	      (loop (car tail)
		    (cdr tail)))))))))

(define-method (session:set-page! (self <session>) page_name)
  (slot-set! self 'page page_name))
(define (session:set-page! self page_name)
  (sdat-set-page! self page_name))

(define-method (session:close (self <session>))
  (dbi:close (slot-ref self 'conn)))
;; (close-output-port (slot-ref self 'logpt))
(define (session:close self)
  (dbi:close (sdat-get-conn self)))
;; (close-output-port (sdat-get-logpt self))

(define-method (session:err-msg (self <session>) msg)
  (hash-table-set! (slot-ref self 'sessionvars) "ERROR_MSG"
(define (session:err-msg self msg)
  (hash-table-set! (sdat-get-sessionvars self) "ERROR_MSG"
		   (string-intersperse (map s:any->string msg) " ")))

(define-method (session:prev-err (self <session>))
  (let ((prev-err (hash-table-ref/default (slot-ref self 'sessionvars-before) "ERROR_MSG" #f))
	(curr-err (hash-table-ref/default (slot-ref self 'sessionvars) "ERROR_MSG" #f)))
(define (session:prev-err self)
  (let ((prev-err (hash-table-ref/default (sdat-get-sessionvars-before self) "ERROR_MSG" #f))
	(curr-err (hash-table-ref/default (sdat-get-sessionvars self) "ERROR_MSG" #f)))
    (if prev-err prev-err
	(if curr-err curr-err #f))))

;; session vars
;; 1. keys are always a string NOT a symbol
;; 2. values are always a string conversion is the responsibility of the 
;;    consuming function (at least for now, I'd like to change this)

;; set a session var for the current page
;;
(define-method (session:set! (self <session>) key value)
  (hash-table-set! (slot-ref self 'pagevars) (s:any->string key) (s:any->string value)))
(define (session:curr-page-set! self key value)
  (hash-table-set! (sdat-get-pagevars self) (s:any->string key) (s:any->string value)))

;; del a var for the current page
;;
(define-method (session:del! (self <session>) key)
  (hash-table-delete! (slot-ref self 'pagevars) (s:any->string key)))
(define (session:page-var-del! self key)
  (hash-table-delete! (sdat-get-pagevars self) (s:any->string key)))

;; get the appropriate hash given a page "*sessionvars*, *globalvars* or page
;;
(define-method (session:get-page-hash (self <session>) page)
(define (session:get-page-hash self page)
  (if (string=? page "*sessionvars*")
      (slot-ref self 'sessionvars)
      (sdat-get-sessionvars self)
      (if (string=? page "*globalvars*")
	  (slot-ref self 'globalvars)
	  (slot-ref self 'pagevars))))
	  (sdat-get-globalvars self)
	  (sdat-get-pagevars self))))

;; set a session var for a given page
;;
(define-method (session:set! (self <session>) page key value)
(define (session:set! self page key value)
  (let ((ht (session:get-page-hash self page)))
    (hash-table-set! ht (s:any->string key) (s:any->string value))))

;; get session vars for the current page
;;
(define-method (session:get (self <session>) key)
  (hash-table-ref/default (slot-ref self 'pagevars) key #f))
(define (session:page-get self key)
  (hash-table-ref/default (sdat-get-pagevars self) key #f))

;; get session vars for a specified page
;;
(define-method (session:get (self <session>) page key)
(define (session:get self page key)
  (let ((ht (session:get-page-hash self page)))
    (hash-table-ref/default ht key #f)))

;; delete a session var for a specified page
;;
(define-method (session:del! (self <session>) page key)
(define (session:del! self page key)
  (let ((ht (session:get-page-hash self page)))
    (hash-table-delete! ht key)))

;; get ALL keys for this page and store in the session pagevars hash
;;
(define-method (session:get-vars (self <session>))
  (let ((session-id  (slot-ref self 'session-id)))
(define (session:get-vars self)
  (let ((session-id  (sdat-get-session-id self)))
    (if (not session-id)
	(err:log "ERROR: No session id in session object! session:get-vars")
	(let* ((result             #f)
	       (conn               (slot-ref self 'conn))
	       (pagevars-before    (slot-ref self 'pagevars-before))
	       (sessionvars-before (slot-ref self 'sessionvars-before))
	       (globalvars-before  (slot-ref self 'globalvars-before))
	       (pagevars           (slot-ref self 'pagevars))
	       (sessionvars        (slot-ref self 'sessionvars))
	       (globalvars         (slot-ref self 'globalvars))
	       (page-name          (slot-ref self 'page))
	       (session-key        (slot-ref self 'session-key))
	       (conn               (sdat-get-conn self))
	       (pagevars-before    (sdat-get-pagevars-before self))
	       (sessionvars-before (sdat-get-sessionvars-before self))
	       (globalvars-before  (sdat-get-globalvars-before self))
	       (pagevars           (sdat-get-pagevars self))
	       (sessionvars        (sdat-get-sessionvars self))
	       (globalvars         (sdat-get-globalvars self))
	       (page-name          (sdat-get-page self))
	       (session-key        (sdat-get-session-key self))
	       (query              (string-append
				    "SELECT key,value FROM session_vars INNER JOIN sessions ON session_vars.session_id=sessions.id "
				    "WHERE session_key=? AND page=?;")))
	  ;; first the page specific vars
	  (dbi:for-each-row (lambda (tuple)
			      (let ((k (vector-ref tuple 0))
				    (v (vector-ref tuple 1)))

				    (v (vector-ref tuple 1)))
				(hash-table-set! globalvars-before k v)
				(hash-table-set! globalvars        k v)))
			    conn
			    (s:sqlparam query session-key "*globalvars"))
	  ))))

(define-method (session:save-vars (self <session>))
  (let ((session-id  (slot-ref self 'session-id)))
(define (session:save-vars self)
  (let ((session-id  (sdat-get-session-id self)))
    (if (not session-id)
	(err:log "ERROR: No session id in session object! session:get-vars")
	(let* ((status      #f)
	       (conn        (slot-ref self 'conn))
	       (page-name   (slot-ref self 'page))
	       (conn        (sdat-get-conn self))
	       (page-name   (sdat-get-page self))
	       (del-query   "DELETE FROM session_vars WHERE session_id=? AND page=? AND key=?;")
	       (ins-query   "INSERT INTO session_vars (session_id,page,key,value) VALUES(?,?,?,?);")
	       (upd-query   "UPDATE session_vars set value=? WHERE key=? AND session_id=? AND page=?;")
	       (changed-count 0))
	  ;; save the delta only
	  (for-each
	   (lambda (page) ;; page is: "*globalvars*" "*sessionvars*" or otherstring
	     (let* ((master-slot-name (cond
				       ((string=? page "*sessionvars*") 'sessionvars)
				       ((string=? page "*globalvars*")  'globalvars)
				       (else 'pagevars)))
	     (let* ((before-after-ht (cond
				      ((string=? page "*sessionvars*")
				       (vector (sdat-get-sessionvars self)
					       (sdat-get-sessionvars-before self)))
				       ((string=? page "*globalvars*")
					(vector (sdat-get-globalvars self)
						(sdat-get-globalvars-before self)))
				       (else 
		    (before-slot-name (string->symbol (string-append (symbol->string master-slot-name)
								     "-before")))
		    (master-ht   (slot-ref self master-slot-name))
		    (before-ht   (slot-ref self before-slot-name))
					(vector (sdat-get-pagevars self)
						(sdat-get-pagevars-before self)))))
		    (master-ht   (vector-ref before-after-ht 0))
		    (before-ht   (vector-ref before-after-ht 1))
		    (master-keys (hash-table-keys master-ht))
		    (before-keys (hash-table-keys before-ht))
		    (all-keys (delete-duplicates (append master-keys before-keys))))
	       (for-each 
		(lambda (key)
		  (let ((master-value (hash-table-ref/default master-ht key #f))
			(before-value (hash-table-ref/default before-ht key #f)))

					  (set! changed-count (+ changed-count 1)))
					conn
					(s:sqlparam ins-query session-id page key master-value)))
		     (else (err:log "Shouldn't get here")))))
		all-keys))) ;; process all keys
	   (list "*sessionvars*" "*globalvars*" page-name))))))

;; 	  ;; (print del-query)
;;           (for-each
;;            (lambda (page)
;;              (pg:query-for-each (lambda (tuple)
;;                                   (set! status #t))
;;                                 (s:sqlparam del-query session-id page-name)
;;                                 conn))
;;            (list page-name "*sessionvars"))
;;           ;; NOTE: The following approach is inefficient and a little dangerous. Need to keep
;;           ;;       two hashes, before and after and use the delta to drive updating the db OR
;;           ;;       even better move to using rpc with a central process for maintaining state
;;           ;; write the session page specific vars to the db
;; 	  (for-each (lambda (key)
;; 		      (pg:query-for-each (lambda (tuple)
;; 					   (set! status #t))
;; 					 (s:sqlparam ins-query session-id page-name
;;                                                      (s:any->string key) ;; just in case it is a symbol
;;                                                      (hash-table-ref pagevars key))
;; 					 conn))
;; 		    (hash-table-keys pagevars))
;;           ;; write the session specific vars to the db
;;           ;; BUG!!! THIS IS LAZY AND WILL BREAK FOR SOMEONE ACCESSING THE SAME SESSION FROM TWO WINDOWS!!!
;; 	  (for-each (lambda (key)
;; 		      (pg:query-for-each (lambda (tuple)
;; 					   (set! status #t))
;; 					 (s:sqlparam ins-query session-id "*sessionvars*"
;;                                                      (s:any->string key) ;; just in case it is a symbol
;;                                                      (hash-table-ref sessionvars key))
;; 					 conn))
;; 		    (hash-table-keys sessionvars))
;;           ;; global vars will require a little more care - delaying for now.
;;           ))))

;; (pg:sql-null-object? element)
(define-method (session:read-config (self <session>))
(define (session:read-config self)
  (let ((name (string-append "." (pathname-file (car (argv))) ".config")))
    (if (not (file-exists? name))
	(print name " not found at " (current-directory))
	(let* ((fp (open-input-file name))
	       (initargs (read fp)))
	  (close-input-port fp)
	  initargs))))

  (let ((p (open-input-file f)))
    (let loop ((hed (read-line p))
	       (res '()))
      (if (eof-object? hed)
	  res
	  (loop (read-line p)(append res (list hed)))))))

(define (process-port p)
  (let ((e (interaction-environment)))
    (map 
     (lambda (x)
       (cond
	((list? x) x)
	((string? x) x)
	(else '())))
     (port-map (lambda (s)
		 (eval s e))
	       (lambda ()(read p))))))

;; May 2011, putting all pages into one directory for the following reasons:
;;   1. want filename to reflect page name (emacs limitation)
;;   2. that's it! no other reason. could make it configurable ...
(define-method (session:call-parts (self <session>) page parts)
  (slot-set! self 'curr-page page)
  ;; (session:log self "page-dir-style: " (slot-ref self 'page-dir-style))
  (let* ((dir-style ;; (equal? (slot-ref self 'page-dir-style) "onedir")) ;; flag #t for onedir, #f for old style
	  (slot-ref self 'page-dir-style))
	 (dir     (string-append (slot-ref self 'sroot) 
(define (session:call-parts self page parts)
  (sdat-set-curr-page! self page)
  ;; (session:log self "page-dir-style: " (sdat-get-page-dir-style self))
  (let* ((dir-style ;; (equal? (sdat-get-page-dir-style self) "onedir")) ;; flag #t for onedir, #f for old style
	  (sdat-get-page-dir-style self))
	 (dir     (string-append (sdat-get-sroot self) 
				 (if dir-style 
				     (conc "/pages/")
				     (conc "/pages/" page))))
	 (control (string-append dir (if dir-style 
					 (conc page "_ctrl.scm")
					 "/control.scm")))
	 (view    (string-append dir (if dir-style 

    ;; (print "dir=" dir " control=" control " view=" view " load-view=" load-view " load=control=" load-control)
    (if load-control
	(begin
	  (load control)
	  (session:set-called! self page)))
    ;; move this to where it gets exectuted only once
    ;;
    ;;(s:log "s:b yields " (s:b "blah"))
    (if load-view
	;; option one.:
	;; option one:
	;;
	;; (let ((inp (open-input-string 
	;; 	    (files-read->string "/home/matt/kiatoa/stml/sugar.scm" 
	;; 				view))))
	;;   (map 
	;;    (lambda (x)
	;;      (cond
	;;       ((list? x) x)
	;;       ((string? x) x)
	;;       (else '())))
	;;    (port-map eval (lambda ()
	;; 		 (read inp)))))
	;;
	;; option two:
	;;
	(let* (;; (inps (map open-input-file (list view))) ;; sugar view)))
	       (p    (open-input-file view)) ;; (apply make-concatenated-port inps))
	       (dat  (map 
		      (lambda (x)
			(cond
			 ((list? x) x)
			 ((string? x) x)
			 (else '())))
		      (port-map eval (lambda ()(read p))))))
	       (dat  (process-port p)))
		;;(map 
		;;      (lambda (x)
		;;	(cond
		;;	 ((list? x) x)
		;;	 ((string? x) x)
		;;	 (else '())))
		;;      (port-map eval (lambda ()(read p))))))
	  ;; (map close-input-port inps)
	  (close-input-port p)
	  dat)
	(list "<p>Page not found " page " </p>"))))

(define-method (session:call (self <session>) page)
  (session:call-parts self page 'both))
;;(define (session:call self page)
;;  (session:call-parts self page 'both))

(define-method (session:call (self <session>) page parts)
(define (session:call self page parts)
  (session:call-parts self page 'both))

(define-method (session:load-model (self <session>) model)
  (let ((model.scm (string-append (slot-ref self 'sroot) "/models/" model ".scm"))
	(model.so  (string-append (slot-ref self 'sroot) "/models/" model ".so")))
(define (session:load-model self model)
  (let ((model.scm (string-append (sdat-get-sroot self) "/models/" model ".scm"))
	(model.so  (string-append (sdat-get-sroot self) "/models/" model ".so")))
    (if (file-exists? model.so)
	(load model.so)
	(if (file-exists? model.scm)
	    (load model.scm)
	    (s:log "ERROR: model " model.scm " not found")))))

(define-method (session:model-path (self <session>) model)
  (string-append (slot-ref self 'sroot) "/models/" model ".scm"))
(define (session:model-path self model)
  (string-append (sdat-get-sroot self) "/models/" model ".scm"))

(define-method (session:pp-formdat (self <session>))
  (let ((dat (formdat:all->strings (slot-ref self 'formdat))))
(define (session:pp-formdat self)
  (let ((dat (formdat:all->strings (sdat-get-formdat self))))
    (string-intersperse dat "<br> ")))

(define (session:param->string params)
  ;; (err:log "params=" params)
  (if (< (length params) 1)
      ""
      (let loop ((key (car params))
		 (val (cadr params))
		 (tail (cddr params))
		 (result '()))
	(let ((newresult (cons (string-append (s:any->string key) "=" (s:any->string val))
			       result)))
	  (if (< (length tail) 1) ;; true if done
	      (string-intersperse newresult "&")
	      (loop (car tail)(cadr tail)(cddr tail) newresult))))))

(define-method (session:link-to (self <session>) page params)
  (let* ((server    (if (getenv "HTTP_HOST")
			(getenv "HTTP_HOST")
			(getenv "SERVER_NAME")))
	 (script (let ((script-name (string-split (getenv "SCRIPT_NAME") "/")))
(define (session:link-to self page params)
  (let* ((server    (if (get-environment-variable "HTTP_HOST")
			(get-environment-variable "HTTP_HOST")
			(get-environment-variable "SERVER_NAME")))
	 (script (let ((script-name (string-split (get-environment-variable "SCRIPT_NAME") "/")))
		   (if (> (length script-name) 1)
		       (string-append (car script-name) "/" (cadr script-name))
		       (getenv "SCRIPT_NAME")))) ;; build script name from first two elements. This is a hangover from before I used ? in the URL.
	 (session-key (slot-ref self 'session-key))
		       (get-environment-variable "SCRIPT_NAME")))) ;; build script name from first two elements. This is a hangover from before I used ? in the URL.
	 (session-key (sdat-get-session-key self))
	 (paramstr (session:param->string params)))
    ;; (session:log self "server=" server " script=" script " page=" page)
    (string-append "http://" server "/" script "/" page "?" paramstr))) ;; "/sn=" session-key)))

(define-method (session:cgi-out (self <session>))
  (let* ((content  (list (slot-ref self 'content-type))) ;; '("Content-type: text/html; charset=iso-8859-1\n\n"))
	 (header   (let ((cookie (slot-ref self 'session-cookie)))
(define (session:cgi-out self)
  (let* ((content  (list (sdat-get-content-type self))) ;; '("Content-type: text/html; charset=iso-8859-1\n\n"))
	 (header   (let ((cookie (sdat-get-session-cookie self)))
		     (if cookie
			 (cons (string-append "Set-Cookie: " (car cookie))
			       content)
			 content)))
	 (pagedat  (slot-ref self 'pagedat)))
	 (pagedat  (sdat-get-pagedat self)))
    (s:cgi-out 
     (cons header pagedat))))

(define-method (session:log (self <session>) . msg)
  (with-output-to-port (slot-ref self 'log-port) ;; (slot-ref self 'logpt)
(define (session:log self . msg)
  (with-output-to-port (sdat-get-log-port self) ;; (sdat-get-logpt self)
    (lambda () 
      (apply print msg))))

(define-method (session:get-param (self <session>) key)
(define (session:get-param self key)
  ;; (session:log s:session "params=" (slot-ref s:session 'params))
  (let ((params (slot-ref self 'params)))
  (let ((params (sdat-get-params self)))
    (session:get-param-from params key)))

;; This one will get the first value found regardless of form
(define-method (session:get-input (self <session>) key)
  (let* ((formdat (slot-ref self 'formdat)))
(define (session:get-input self key)
  (let* ((formdat (sdat-get-formdat self)))
    (if (not formdat) #f
	(if (or (string? key)(number? key)(symbol? key))
	    (if (eq? (class-of formdat) <formdat>)
	    (if (and (vector? formdat)(eq? (vector-length formdat) 1)(hash-table? (vector-ref formdat 0)))
		(formdat:get formdat key)
		(begin
		  (session:log self "ERROR: formdat: " formdat " is not of class <formdat>")
		  #f))
	    (session:log self "ERROR: bad key " key)))))

(define-method (session:run-actions (self <session>))
(define (session:run-actions self)
  (let* ((action    (session:get-param self 'action))
	 (page      (slot-ref self 'page)))
	 (page      (sdat-get-page self)))
    ;; (print "action=" action " page=" page)
    (if action
	(let ((action-lst  (string-split action ".")))
	  ;; (print "action-lst=" action-lst)
	  (if (not (= (length action-lst) 2)) 
	      (err:log "Action should be of form: module.action")
	      (let* ((targ-page   (car action-lst))

		    ((eval (string->symbol proc-name)) targ-action) ;; unsafe execution
		    (condition-case ((eval (string->symbol proc-name)) targ-action)
				    ((exn file) (s:log "file error"))
				    ((exn i/o)  (s:log "i/o error"))
				    ((exn )     (s:log "Action not implemented: " proc-name " action: " targ-action))
				    (var ()     (s:log "Unknown Error"))))))))))

(define-method (session:never-called-page? (self <session>) page)
(define (session:never-called-page? self page)
  (session:log self "Checking for page: " page)
  (not (member page (slot-ref self 'seen-pages))))
  (not (member page (sdat-get-seen-pages self))))

(define-method (session:set-called! (self <session>) page)
  (slot-set! self 'seen-pages (cons page (slot-ref self 'seen-pages))))
(define (session:set-called! self page)
  (sdat-set-seen-pages! self (cons page (sdat-get-seen-pages self))))

;;======================================================================
;; Alternative data type delivery
;;======================================================================

(define-method (session:alt-out (self <session>))
  (let ((dat (slot-ref self 'alt-page-dat)))
(define (session:alt-out self)
  (let ((dat (sdat-get-alt-page-dat self)))
    ;; (s:log "dat is: " dat)
    ;; (print "HTTP/1.1 200 OK")
    (print "Date: " (time->string (seconds->utc-time (current-seconds))))
    (print "Content-Type: " (slot-ref self 'content-type))
    (print "Content-Type: " (sdat-get-content-type self))
    (print "Accept-Ranges: bytes")
    (print "Content-Length: " (if (blob? dat)
				  (blob-size dat)
				  0))
    (print "Keep-Alive: timeout=15, max=100")
    (print "Connection: Keep-Alive")
    (print "")
    (write-string (blob->string dat) #f (current-output-port))))

;; Copyright 2007-2008, Matthew Welland.
;; Copyright 2007-2011, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

(declare (unit setup))
(declare (uses session))
(require-extension srfi-69)
(require-extension regex)

;; 
(define s:session (make <session>))
(define s:session (make-sdat))
(session:initialize s:session)

;; use this for getting data from page to page when scope and evals
;; get in the way
(define s:local-vars (make-hash-table))

(define (s:local-set! k v)
  (hash-table-set! s:local-vars k v))

(define (s:local-get k)
  (hash-table-ref/default s:local-vars k #f))

(session:setup s:session)

(define (s:log . msg)
  (apply session:log s:session msg))

(session:get-vars s:session)

(define (s:set-err . args)
  (slot-set! s:session 'curr-err args))
  (sdat-set-curr-err s:session args))

;; Usage: (s:get-err s:big)
(define (s:get-err wrapperfunc)
  (let ((errmsg (slot-ref s:session 'curr-err)))
  (let ((errmsg (sdat-get-curr-err s:session)))
    (if errmsg ((if wrapperfunc
                    wrapperfunc
                    s:strong) errmsg) '())))

(define (s:current-page)
  (slot-ref s:session 'page))
  (sdat-get-page s:session))

(define (s:delete-session)
  (session:delete-session s:session (slot-ref s:session 'session-key)))
  (session:delete-session s:session (sdat-get-session-key s:session)))

(define (s:call page . partsl)
  (if (null? partsl)
      (session:call s:session page)
      (session:call s:session page #f)
      (session:call s:session page (car partsl))))

(define (s:link-to page . params)
  (session:link-to s:session page params))

(define (s:get-param key)
  (session:get-param s:session key))

;; these are page local
(define (s:get key) 
  (session:get s:session key))
  (session:page-get s:session key))

(define (s:set! key val)
  (session:set! s:session key val))
  (session:curr-page-set! s:session key val))

(define (s:del! key)
  (session:del! s:session key))
  (session:page-var-del! s:session key))

(define (s:get-n-del! key)
  (let ((val (session:get s:session key)))
  (let ((val (session:page-get s:session key)))
    (session:del! s:session key)
    val))

;; these are session wide
(define (s:session-var-get key) 
  (session:get s:session "*sessionvars*" key))

(define (s:session-var-set! key val)
  (session:set! s:session "*sessionvars*" key val))

(define (s:session-var-get-n-del! key)
  (let ((val (session:get s:session key)))
  (let ((val (session:page-get s:session key)))
     (session:del! s:session "*sessionvars*" key)
     val))

(define (s:session-var-del! key)
  (session:del! s:session "*sessionvars*" key))

;;
(define (s:get-input key)
  (session:get-input s:session key))

(define (s:load-model model)
  (session:load-model s:session model))

(define (s:model-path model)
  (session:model-path s:session model))

(define (s:db)
  (slot-ref s:session 'conn))
  (sdat-get-conn s:session))

(define (s:never-called-page? page)
  (session:never-called-page? s:session page))

;; Copyright 2007-2008, Matthew Welland.
;; Copyright 2007-2011, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
;; Copyright 2007-2011, Matthew Welland. Kiatoa.com All rights reserved.
;; 

;; DON'T USE THIS!!!! It was a bad idea :-(

;; If performance becomes an issue upgrade this to use a vector to 

(require-extension tinyclos)
;; (require-extension tinyclos)

(define-class <sqltbl> ()
  (rows
   fields       ;; list of field
   fields-hash  ;; hash of fields -> number
   query        ;; query string using ?'s
   query-params ;; list of params for the query
   conn         ;; connection to db
   num-rows     ;; whatever 
   curr-row-ptr ;; number of the current row
   curr-row     ;; the current row vector (?? do we really want this ??)
   ))
;; (define-class <sqltbl> ()
;;   (rows
;;    fields       ;; list of field
;;    fields-hash  ;; hash of fields -> number
;;    query        ;; query string using ?'s
;;    query-params ;; list of params for the query
;;    conn         ;; connection to db
;;    num-rows     ;; whatever 
;;    curr-row-ptr ;; number of the current row
;;    curr-row     ;; the current row vector (?? do we really want this ??)
;;    ))

(declare (unit sqltbl))

(define (make-sqltbl:tbl)(make-vector 9))
(define-inline (sqltbl:tbl-get-rows           vec)    (vector-ref  vec 0))
(define-inline (sqltbl:tbl-get-fields         vec)    (vector-ref  vec 1))
(define-inline (sqltbl:tbl-get-fields-hash    vec)    (vector-ref  vec 2))
(define-inline (sqltbl:tbl-get-query          vec)    (vector-ref  vec 3))
(define-inline (sqltbl:tbl-get-query-params   vec)    (vector-ref  vec 4))
(define-inline (sqltbl:tbl-get-conn           vec)    (vector-ref  vec 5))
(define-inline (sqltbl:tbl-get-num-rows       vec)    (vector-ref  vec 6))
(define-inline (sqltbl:tbl-get-curr-row-ptr   vec)    (vector-ref  vec 7))
(define-inline (sqltbl:tbl-get-curr-row       vec)    (vector-ref  vec 8))
(define-inline (sqltbl:tbl-set-rows!          vec val)(vector-set! vec 0 val))
(define-inline (sqltbl:tbl-set-fields!        vec val)(vector-set! vec 1 val))
(define-inline (sqltbl:tbl-set-fields-hash!   vec val)(vector-set! vec 2 val))
(define-inline (sqltbl:tbl-set-query!         vec val)(vector-set! vec 3 val))
(define-inline (sqltbl:tbl-set-query-params!  vec val)(vector-set! vec 4 val))
(define-inline (sqltbl:tbl-set-conn!          vec val)(vector-set! vec 5 val))
(define-inline (sqltbl:tbl-set-num-rows!      vec val)(vector-set! vec 6 val))
(define-inline (sqltbl:tbl-set-curr-row-ptr!  vec val)(vector-set! vec 7 val))
(define-inline (sqltbl:tbl-set-curr-row!      vec val)(vector-set! vec 8 val))

(define-method (initialize (self <sqltbl>) initargs)
(define  (sqltbl:initialize self);; initargs)
  (call-next-method)
  (slot-set! self 'num-rows 0)
  (slot-set! self 'curr-row-ptr 0)
  (slot-set! self 'fields '())
  (slot-set! self 'fields-hash (make-hash-table))
  (initialize-slots self initargs))
;;  (if (> (length (slot-ref self 'rows) 0))
;;      (slot-set! self 'curr-row (car rows))))
  (sqltbl:tbl-set-num-rows! self 0)
  (sqltbl:tbl-set-curr-row-ptr! self 0)
  (sqltbl:tbl-set-fields! self '())
  (sqltbl:tbl-set-fields-hash! self (make-hash-table)))
  ;; (initialize-slots self initargs))
;;  (if (> (length (sqltbl:tbl-get-rows self) 0))
;;      (sqltbl:tbl-set-curr-row! self (car rows))))

(define-method (sqltbl:next-row (self <sqltbl>))
  (let ((curr-row-ptr (+ (slot-ref self 'curr-row-ptr) 1))
        (num-rows     (slot-ref self 'num-rows))
        (rows         (slot-ref self 'rows)))
    (if (> curr-row-prt (slot-ref self 'num-rows)) #f ;; there is no next row
(define (sqltbl:next-row self)
  (let ((curr-row-ptr (+ (sqltbl:tbl-get-curr-row-ptr self) 1))
        (num-rows     (sqltbl:tbl-get-num-rows self))
        (rows         (sqltbl:tbl-get-rows self)))
    (if (> curr-row-prt (sqltbl:tbl-get-num-rows self)) #f ;; there is no next row
        (let ((new-curr-row (list-ref rows curr-row-ptr)))
          (slot-set! self 'curr-row new-curr-row)
          (slot-set! self 'curr-row-prt curr-row-prt)
          (sqltbl:tbl-set-curr-row! self new-curr-row)
          (sqltbl:tbl-set-curr-row-prt! self curr-row-prt)
          new-curr-row))))

;; run the query and fill the rows list 
(define-method (sqltbl:run-query (self <sqltbl>) . params)
  (let* ((query  (slot-ref self 'query))
         (fields (slot-ref self 'fields))
(define (sqltbl:run-query self . params)
  (let* ((query  (sqltbl:tbl-get-query self))
         (fields (sqltbl:tbl-get-fields self))
         (rows (let ((result '())
                     (actual-query (apply s:sqlparam query fields params)))
                 ;; (s:log "actual-query=" actual-query)
                 (dbi:for-each-row (lambda (tuple)
                                      (set! result (cons tuple result)))
                                    (slot-ref self 'conn)
                                    (sqltbl:tbl-get-conn self)
				actual-query)
                 (slot-set! self 'query-params params)
                 (slot-set! self 'num-rows (length result))
                 (sqltbl:tbl-set-query-params! self params)
                 (sqltbl:tbl-set-num-rows! self (length result))
                 (sqltbl:setup-fields self)  ;; update the fields lookup hash
                 (reverse result))))
    (slot-set! self 'rows rows)
    (sqltbl:tbl-set-rows! self rows)
    (if (not (null? rows))
        (slot-set! self 'curr-row (car rows)))
    (slot-set! self 'curr-row-ptr 0)
        (sqltbl:tbl-set-curr-row! self (car rows)))
    (sqltbl:tbl-set-curr-row-ptr! self 0)
    rows))

(define-method (sqltbl:setup-fields (self <sqltbl>))
  (let ((fields-hash (slot-ref self 'fields-hash))
        (fields-list (slot-ref self 'fields)))
(define (sqltbl:setup-fields self)
  (let ((fields-hash (sqltbl:tbl-get-fields-hash self))
        (fields-list (sqltbl:tbl-get-fields self)))
    (let loop ((head (car fields-list))
               (tail (cdr fields-list))
               (fnum 0))
      (hash-table-set! fields-hash head fnum)
      (if (null? tail) fnum
          (loop (car tail)(cdr tail)(+ fnum 1))))))

;; get a value from the current row
(define-method (sqltbl:get-field-value-curr (self <sqltbl>) field)
  (let ((curr-row  (slot-ref self 'curr-row))
        (field-num (hash-table-ref/default (slot-ref self 'fields-hash) field #f)))
(define (sqltbl:get-field-value-curr self field)
  (let ((curr-row  (sqltbl:tbl-get-curr-row self))
        (field-num (hash-table-ref/default (sqltbl:tbl-get-fields-hash self) field #f)))
    (if field-num 
        (vector-ref curr-row field-num)
        #f))) ;; not found -> #f

(define-method (sqltbl:vector->hash (self <sqltbl>) vec)
(define (sqltbl:vector->hash self vec)
  (let ((h      (make-hash-table))
        (fields (slot-ref self 'fields)))
        (fields (sqltbl:tbl-get-fields self)))
    (do ((i 0 (+ i 1)))
        ((>= i (length fields)))
      (hash-table-set! h (list-ref fields i)(vector-ref vec i)))
    h))


;; runs proc on each row and returns the resulting list
(define-method (sqltbl:map (self <sqltbl>) proc)
(define (sqltbl:map self proc)
  (map (lambda (row)
         (proc (sqltbl:vector->hash self row))) (slot-ref self 'rows)))
         (proc (sqltbl:vector->hash self row))) (sqltbl:tbl-get-rows self)))
   

(list sroot   "/path/to/{pages,models}/dir"
      logfile "/tmp/stmlrun/logs.log"     ;; this is now required!
      dbtype  'sqlite3 ;; or 'pg
      dbinit  '((dbname   . "test-stml.db")
                (user     . "nobody")
                (password . "Dapassword")
                (host     . "localhost"))
      domain  "192.168.1.150")
'(sroot   "/path/to/{pages,models}/dir"
  logfile "/tmp/stmlrun/logs.log"
  dbtype  sqlite3
  dbinit   ((dbname   . "test-stml.db")
            (user     . "nobody")
            (password . "Dapassword")
            (host     . "localhost"))
  domain  "192.168.1.150")

;; Copyright 2007-2008, Matthew Welland.
;; Copyright 2007-2011, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

;; stml is a list of html strings

(declare (unit stml))
(declare (uses misc-stml))

;; extract various tokens from the parameter list
;;   'key val => put in the params list
;;   strings  => maintain order and add to the datalist <<== IMPORTANT
(define (s:extract inlst)
  (if (null? inlst) inlst
      (let loop ((data '())
                 (params '())

(define (s:form   . args)
  ;; create a link for calling back into the current page and calling a specified 
  ;; function
  (let* ((action     (let ((v (s:find-param 'action args)))
                       (if v v "default")))
	 (id         (let ((i (s:find-param 'id args)))
		       (if i i #f)))
         (page       (let ((p (slot-ref s:session 'page)))
         (page       (let ((p (sdat-get-page s:session)))
                       (if p p "home")))
	 ;; (link       (session:link-to s:session page (if id
         ;;                                                 (list 'action action 'id id)
         ;;                                                 (list 'action action)))))
	 (link       (if (string=? (substring action 0 5) "http:") ;; if first part of string is http:
	        	 action
	        	 (session:link-to s:session 

#!/usr/local/bin/csi -q

;; Copyright 2007-2008, Matthew Welland.
;; Copyright 2007-2011, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

;; (require-extension syntax-case)
(declare (run-time-macros))
;; (declare (run-time-macros))

(use dbi)
(require-library dbi)

(include "requirements.scm")
(declare (uses cookie))
(include "html-filter.scm")
(include "misc-stml.scm")
(include "formdat.scm")
(include "stml.scm")
(declare (uses html-filter))
(declare (uses misc-stml))
(declare (uses formdat))
(declare (uses stml))
;; (include "dbi.scm")
(include "session.scm")
(include "setup.scm") ;; s:session gets created here
(include "sqltbl.scm")
(include "keystore.scm")
(declare (uses session))
(declare (uses setup)) ;; s:session gets created here
(declare (uses sqltbl))
(declare (uses keystore))
(include "sugar.scm")

(slot-set! s:session 'log-port ;; (current-error-port))
	   (open-output-file (slot-ref s:session 'logfile) #:append))
(sdat-set-log-port! s:session ;; (current-error-port))
	   (open-output-file (sdat-get-logfile s:session) #:append))

;; (s:log "HTTP_COOKIE" (getenv "HTTP_COOKIE"))
;; (s:log "HTTP_COOKIE" (get-environment-variable "HTTP_COOKIE"))
;; (s:log "stdin-dat=" (slot-ref s:session 'stdin-dat))

(s:validate-inputs)

(session:run-actions s:session)

(slot-set! s:session 'pagedat 
           (append (slot-ref s:session 'pagedat)
                   (s:call (slot-ref s:session 'toppage))))
(sdat-set-pagedat! s:session
           (append (sdat-get-pagedat s:session)
                   (s:call (sdat-get-toppage s:session))))

(if (eq? (slot-ref s:session 'page-type) 'html) ;; default is html. 
(if (eq? (sdat-get-page-type s:session) 'html) ;; default is html. 
    (session:cgi-out s:session)
    (session:alt-out s:session))

(session:save-vars s:session)

(session:close s:session)

;; Copyright 2007-2008, Matthew Welland.
;; Copyright 2007-2011, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

(use test md5)

(require-extension sqlite3)
(import (prefix sqlite3 sqlite3:))

(require-library dbi)

;; (declare (uses stml))

(include "requirements.scm")
(include "cookie.scm")
(include "misc-stml.scm")
(include "formdat.scm")
(include "stml.scm")
(include "session.scm")
(include "sqltbl.scm")
(include "html-filter.scm")
(include "keystore.scm")

(define p (open-input-file "test.stml"))
(print (process-port p))
(close-input-port p)

;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
;; 
;; index

(list
 (s:html
  (s:head
   (s:title "Kiatoa")
   (s:link  'rel "stylesheet" 'type "text/css" 'href "/kiatoa/markup.css")
   (s:link  'rel "stylesheet" 'type "text/css" 'href "/kiatoa/layout.css"))))

#!/usr/local/bin/csi -q 

;; Copyright 2007-2008, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

(use test md5 dbi)
(use test md5)

(require-extension sqlite3)
(import (prefix sqlite3 sqlite3:))

(require-library dbi)

(load "./requirements.scm")
(load "./cookie.so")
(load "./misc-stml.scm")
(load "./formdat.scm")
(load "./stml.scm")
(load "./session.scm")
(load "./sqltbl.scm")
(load "./html-filter.scm")
(load "./keystore.scm")

;; (test "Session var del"                    #f   (s:session-var-get "nick"))

;; test person

(load "./tests/models/test.scm")

(print "Session key is " (slot-ref s:session 'session-key))
(print "Session key is " (sdat-get-session-key s:session))

(test "Delete session" #t (s:delete-session))

(let ((fh (open-input-pipe "ls ./tests/pages/*/control.scm")))
  (let loop ((l (read-line fh)))
    (if (not (eof-object? l))
        (begin

(test "misc:non-zero-string \"\"" #f (misc:non-zero-string ""))
(test "misc:non-zero-string #f" #f (misc:non-zero-string #f))
(test "misc:non-zero-string 'blah" #f (misc:non-zero-string 'blah))

;; forms
(define form #f)
(test "make <formdat>" #t (let ((f (make <formdat>)))
(test "make <formdat>" #t (let ((f (make-formdat:formdat)))
			    (set! form f)
			    #t))
(test "formdat: set!/get" "Yep!" (begin
				   (formdat:set! form "blah" "Yep!")
				   (formdat:get  form "blah")))

(test "s:string->pgint"   123 (s:any->pgint "123"))