;; (declare (unit stml))

(module stml2
    *

(import chicken scheme data-structures extras srfi-13 ports posix srfi-69 files srfi-1) 

(use cookie (prefix dbi dbi:) (prefix crypt c:) typed-records)

;; (declare (uses misc-stml))
(use regex)

;; The (usually global) sdat contains everything about the session
;;
(defstruct sdat
  (dbtype 'pg)
  (dbinit #f)
  (conn   #f)
  (page "home")
  (page-type 'html)
  (toppage "index")
  (content-type "Content-type: text/html; charset=iso-8859-1\n\n")
  (formdat      #f)
  (params '())
  (path-params '())
  (session-key #f)
  (pagedat     '())
  (curr-page    "home")
  (alt-page-dat #f)
  (sroot         "./")
  (session-cookie #f)
  (curr-err       #f)
  (log-port       (current-error-port))
  (logfile        "/tmp/stml.log")
  (seen-pages     '())
  (page-dir-style  #t)
  (debug-mode      #f)
  (session-id      #f)
  (pagevars        (make-hash-table))
  (pagevars-before (make-hash-table))
  (sessionvars     (make-hash-table))
  (sessionvars-before (make-hash-table))
  (globalvars      (make-hash-table))
  (globalvars-before (make-hash-table))
  (request-method  #f)
  (domain          "localhost")
  (twikidir        #f)
  (script          #f)
  (force-ssl       #f)
  (shared-hash     (make-hash-table)))

(define (apply-config-file session #!optional (configf #f))
  (let* ((rawconfigdat (session:read-config session configf))
	 (configdat (if rawconfigdat (eval rawconfigdat) '()))
	 (sroot     (s:find-param 'sroot    configdat))
	 (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))
	 (debugmode (s:find-param 'debugmode configdat))
         (script    (s:find-param 'script    configdat))
	 (force-ssl (s:find-param 'force-ssl configdat)))
    (if sroot    (sdat-sroot-set!      session sroot))
    (if logfile  (sdat-logfile-set!    session logfile))
    (if dbtype   (sdat-dbtype-set!     session dbtype))
    (if dbinit   (sdat-dbinit-set!     session dbinit))
    (if domain   (sdat-domain-set!     session domain))
    (if twikidir (sdat-twikidir-set!   session twikidir))
    (if debugmode (sdat-debug-mode-set! session debugmode))
    (if script    (sdat-script-set!    session script))
    (if force-ssl (sdat-force-ssl-set! session force-ssl))
    (sdat-page-dir-style-set! session page-dir)
    ;; (print "configdat: ")(pp configdat)
    (if debugmode
	(session:log session "sroot: " sroot " logfile: " logfile " dbtype: " dbtype 
		     " dbinit: " dbinit " domain: " domain " page-dir-style: " page-dir))
    ))

;; 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 '())

(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 (sdat-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 

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

;; share data between pages calls. NOTE: This is not persistent
;; between cgi calls. Use sessionvars for that.
;;
(define (s:shared-hash)
  (sdat-shared-hash s:session))

(define (s:shared-set! key val)
  (hash-table-set! (sdat-shared-hash s:session) key val))

;; What to return when no value for key?
;;
(define (s:shared-get key)
  (hash-table-ref/default (sdat-shared-hash s:session) key #f))

;; http://foo.bar.com/pagename/p1/p2 => '("p1" "p2")
;;  #### DEPRECATED ####
(define (s:get-page-params)
  (sdat-path-params s:session))

(define (s:get-path-params)
  (sdat-path-params s:session))
	

(define (s:db)
  (sdat-conn s:session))

;;======================================================================
;; cgi and session stuff
;;======================================================================

;;(declare (uses cookie))
;;(declare (uses html-filter))

;; 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 (make-sdat)(make-vector 36))
;; (define (sdat-dbtype               vec)    (vector-ref  vec 0))
;; (define (sdat-dbinit               vec)    (vector-ref  vec 1))
;; (define (sdat-conn                 vec)    (vector-ref  vec 2))
;; (define (sdat-pgconn               vec)    (vector-ref (vector-ref vec 2) 1))
;; (define (sdat-params               vec)    (vector-ref  vec 3))
;; (define (sdat-path-params          vec)    (vector-ref  vec 4))
;; (define (sdat-session-key          vec)    (vector-ref  vec 5))
;; (define (sdat-session-id           vec)    (vector-ref  vec 6))
;; (define (sdat-domain               vec)    (vector-ref  vec 7))
;; (define (sdat-toppage              vec)    (vector-ref  vec 8))
;; (define (sdat-page                 vec)    (vector-ref  vec 9))
;; (define (sdat-curr-page            vec)    (vector-ref  vec 10))
;; (define (sdat-content-type         vec)    (vector-ref  vec 11))
;; (define (sdat-page-type            vec)    (vector-ref  vec 12))
;; (define (sdat-sroot                vec)    (vector-ref  vec 13))
;; (define (sdat-twikidir             vec)    (vector-ref  vec 14))
;; (define (sdat-pagedat              vec)    (vector-ref  vec 15))
;; (define (sdat-alt-page-dat         vec)    (vector-ref  vec 16))
;; (define (sdat-pagevars             vec)    (vector-ref  vec 17))
;; (define (sdat-pagevars-before      vec)    (vector-ref  vec 18))
;; (define (sdat-sessionvars          vec)    (vector-ref  vec 19))
;; (define (sdat-sessionvars-before   vec)    (vector-ref  vec 20))
;; (define (sdat-globalvars           vec)    (vector-ref  vec 21))
;; (define (sdat-globalvars-before    vec)    (vector-ref  vec 22))
;; (define (sdat-logpt                vec)    (vector-ref  vec 23))
;; (define (sdat-formdat              vec)    (vector-ref  vec 24))
;; (define (sdat-request-method       vec)    (vector-ref  vec 25))
;; (define (sdat-session-cookie       vec)    (vector-ref  vec 26))
;; (define (sdat-curr-err             vec)    (vector-ref  vec 27))
;; (define (sdat-log-port             vec)    (vector-ref  vec 28))
;; (define (sdat-logfile              vec)    (vector-ref  vec 29))
;; (define (sdat-seen-pages           vec)    (vector-ref  vec 30))
;; (define (sdat-page-dir-style       vec)    (vector-ref  vec 31))
;; (define (sdat-debugmode            vec)    (vector-ref  vec 32))
;; (define (sdat-shared-hash          vec)    (vector-ref  vec 33))
;; (define (sdat-script               vec)    (vector-ref  vec 34))
;; (define (sdat-force-ssl            vec)    (vector-ref  vec 35))
;; 
;; (define (session:get-shared vec varname)
;;   (hash-table-ref/default (vector-ref vec 33) varname #f))
;; 
;; (define (sdat-dbtype-set!              vec val)(vector-set! vec 0 val))
;; (define (sdat-dbinit-set!              vec val)(vector-set! vec 1 val))
;; (define (sdat-conn-set!                vec val)(vector-set! vec 2 val))
;; (define (sdat-params-set!              vec val)(vector-set! vec 3 val))
;; (define (sdat-path-set-params!         vec val)(vector-set! vec 4 val))
;; (define (sdat-session-set-key!         vec val)(vector-set! vec 5 val))
;; (define (sdat-session-set-id!          vec val)(vector-set! vec 6 val))
;; (define (sdat-domain-set!              vec val)(vector-set! vec 7 val))
;; (define (sdat-toppage-set!             vec val)(vector-set! vec 8 val))
;; (define (sdat-page-set!                vec val)(vector-set! vec 9 val))
;; (define (sdat-curr-set-page!           vec val)(vector-set! vec 10 val))
;; (define (sdat-content-set-type!        vec val)(vector-set! vec 11 val))
;; (define (sdat-page-set-type!           vec val)(vector-set! vec 12 val))
;; (define (sdat-sroot-set!               vec val)(vector-set! vec 13 val))
;; (define (sdat-twikidir-set!            vec val)(vector-set! vec 14 val))
;; (define (sdat-pagedat-set!             vec val)(vector-set! vec 15 val))
;; (define (sdat-alt-set-page-dat!        vec val)(vector-set! vec 16 val))
;; (define (sdat-pagevars-set!            vec val)(vector-set! vec 17 val))
;; (define (sdat-pagevars-set-before!     vec val)(vector-set! vec 18 val))
;; (define (sdat-sessionvars-set!         vec val)(vector-set! vec 19 val))
;; (define (sdat-sessionvars-set-before!  vec val)(vector-set! vec 20 val))
;; (define (sdat-globalvars-set!          vec val)(vector-set! vec 21 val))
;; (define (sdat-globalvars-set-before!   vec val)(vector-set! vec 22 val))
;; (define (sdat-logpt-set!               vec val)(vector-set! vec 23 val))
;; (define (sdat-formdat-set!             vec val)(vector-set! vec 24 val))
;; (define (sdat-request-set-method!      vec val)(vector-set! vec 25 val))
;; (define (sdat-session-set-cookie!      vec val)(vector-set! vec 26 val))
;; (define (sdat-curr-set-err!            vec val)(vector-set! vec 27 val))
;; (define (sdat-log-set-port!            vec val)(vector-set! vec 28 val))
;; (define (sdat-logfile-set!             vec val)(vector-set! vec 29 val))
;; (define (sdat-seen-set-pages!          vec val)(vector-set! vec 30 val))
;; (define (sdat-page-set-dir-style!      vec val)(vector-set! vec 31 val))
;; (define (sdat-debugmode-set!           vec val)(vector-set! vec 32 val))
;; (define (sdat-shared-set-hash!         vec val)(vector-set! vec 33 val))
;; (define (sdat-script-set!              vec val)(vector-set! vec 34 val))
;; (define (sdat-force-set-ssl!           vec val)(vector-set! vec 35 val))
;; 
;; (define (session:set-shared! vec varname val)
;;   (hash-table-set! (vector-ref vec 33) varname val))

;; The global session
(define s:session (make-sdat))

;; SPLIT INTO STRAIGHT FORWARD INIT AND COMPLEX INIT
#;(define (session:initialize self #!optional (configf #f))
  (sdat-dbtype-set! self      'pg)
  (sdat-page-set! self        "home")        ;; these are defaults
  (sdat-curr-set-page! self   "home")
  (sdat-content-set-type! self "Content-type: text/html; charset=iso-8859-1\n\n")
  (sdat-page-set-type! self   'html)
  (sdat-toppage-set! self     "index")
  (sdat-params-set! self      '())           ;;
  (sdat-path-set-params! self '())
  (sdat-session-set-key! self #f)
  (sdat-pagedat-set! self     '())
  (sdat-alt-set-page-dat! self #f)
  (sdat-sroot-set! self       "./")
  (sdat-session-set-cookie! self #f)
  (sdat-curr-set-err! self #f)
  (sdat-log-set-port! self (current-error-port))
  (sdat-seen-set-pages! self '())
  (sdat-page-set-dir-style! self #t) ;; #t : pages/<pagename>_(view|cntl).scm
                                      ;; #f : pages/<pagename>/(view|control).scm 
  (sdat-debugmode-set!          self #f)
  			     
  (sdat-pagevars-set!           self (make-hash-table))
  (sdat-sessionvars-set!        self (make-hash-table))
  (sdat-globalvars-set!         self (make-hash-table))
  (sdat-pagevars-set-before!    self (make-hash-table))
  (sdat-sessionvars-set-before! self (make-hash-table))
  (sdat-globalvars-set-before!  self (make-hash-table))
  (sdat-domain-set!             self "locahost")   ;; end of defaults
  (sdat-script-set!             self #f)
  (sdat-force-set-ssl!          self #f)
  (let* ((rawconfigdat (session:read-config self configf))
	 (configdat (if rawconfigdat (eval rawconfigdat) '()))
	 (sroot     (s:find-param 'sroot    configdat))
	 (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))
	 (debugmode (s:find-param 'debugmode configdat))
         (script    (s:find-param 'script    configdat))
	 (force-ssl (s:find-param 'force-ssl configdat)))
    (if sroot    (sdat-sroot-set!    self sroot))
    (if logfile  (sdat-logfile-set!  self logfile))
    (if dbtype   (sdat-dbtype-set!   self dbtype))
    (if dbinit   (sdat-dbinit-set!   self dbinit))
    (if domain   (sdat-domain-set!   self domain))
    (if twikidir (sdat-twikidir-set! self twikidir))
    (if debugmode (sdat-debugmode-set! self debugmode))
    (if script    (sdat-script-set!    self script))
    (if force-ssl (sdat-force-set-ssl! self force-ssl))
    (sdat-page-set-dir-style! self page-dir)
    ;; (print "configdat: ")(pp configdat)
    (if debugmode
	(session:log self "sroot: " sroot " logfile: " logfile " dbtype: " dbtype 
		     " dbinit: " dbinit " domain: " domain " page-dir-style: " page-dir))
    )
  (sdat-shared-set-hash! self (make-hash-table))
  )

;; Used for the strangely inconsistent handling of the config file. A better way is needed.
;;
;;   (let ((dbtype (sdat-dbtype self)))
;;     (print "dbtype: " dbtype)
;;     (sdat-dbtype-set! self (eval dbtype))))

(define (session:setup self)
  (let ((dbtype    (sdat-dbtype self))
	(debugmode (sdat-debug-mode self))
	(dbinit    (eval (sdat-dbinit self)))
	(dbexists  #f))
    (let ((dbfname (alist-ref 'dbname dbinit)))
      (if debugmode (session:log self "session:setup dbfname=" dbfname ", dbtype=" dbtype ", dbinit=" dbinit))
      (if (eq? dbtype 'sqlite3)
	  ;; The 'auto method will distribute dbs across the disk using hash
	  ;; of user host and user. TODO
	  ;; (if (eq? dbfname 'auto) ;; This is the auto assignment of a db based on hash of IP
	  (let ((dbpath (pathname-directory dbfname)))  ;; do a couple sanity checks here to make setting up easier
	    (if debugmode (session:log self "INFO: setting up for sqlite3 db access to " dbfname))
	    (if (not (file-write-access? dbpath))
		(session:log self "WARNING: Cannot write to " dbpath)
		(if debugmode (session:log self "INFO: " dbpath " is writeable")))
	    (if (file-exists? dbfname)
		(begin
		  ;; (session:log self "setting dbexists to #t")
		  (set! dbexists #t))))
	  (if debugmode (session:log self "INFO: setting up for pg db access to account info " dbinit)))
      (if debugmode (session:log self "dbtype: " dbtype " dbfname: " dbfname " dbexists: " dbexists)))
    (sdat-conn-set! self (dbi:open dbtype dbinit))
    (set! *db* (sdat-conn self))
    (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
    (sdat-request-method-set! self (get-environment-variable "REQUEST_METHOD"))
    (sdat-formdat-set! self (formdat:load-all))))

;; setup the db with session tables, works for sqlite only right now
(define (session:setup-db self)
  (let ((conn (sdat-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
;;  (sdat-session-set-id! self (session:get-id self)))

;; only set session-cookie when a new session is created
(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)))
          (sdat-session-key-set! self new-key)
          (sdat-session-id-set! self new-sid)
          (sdat-session-cookie-set! self (session:make-cookie self)))
        (sdat-session-id-set! self sid))))

(define (session:make-cookie self)
  ;; (list (conc "session_key=" (sdat-session-key self) "; Path=/; Domain=." (sdat-domain self) "; Max-Age=" (* 86400 14) "; Version=1"))) 
  ;; According to 
  ;;    http://www.codemarvels.com/2010/11/apache-rewriterule-set-a-cookie-on-localhost/

  ;;  Here are the 2 (often left out) requirements to set a cookie using
  ;;  httpd-F�s rewrite rule (mod_rewrite), while working on localhost:-A
  ;;
  ;;  Use the IP 127.0.0.1 instead of localhost/machine-name as the

  ;;  header, which makes the cookie a persistent one (not really
  ;;  persistent, as the expires value set is the current server time
  ;;  %G–%@ so you don-F-F�t even get to see your cookie!)-A
  (list (string-substitute 
	 ";" "; " 
	 (car (construct-cookie-string 
	       ;; warning! messing up this itty bitty bit of code will cost much time!
	       `(("session_key" ,(sdat-session-key self)
		  expires: ,(+ (current-seconds) (* 14 86400)) 
		  ;; max-age: (* 14 86400)
		  path: "/" ;; 
		  domain: ,(string-append "." (sdat-domain self))
		  version: 1)) 0)))))

;; look up a given session key and return the id if found, #f if not found
(define (session:get-id self session-key)
  ;; (let ((session-key (sdat-session-key self)))
  (if session-key
      (let ((query (string-append "SELECT id FROM sessions WHERE session_key='" session-key "'"))
            (conn (sdat-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 (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)
	      (sdat-page-set! self (car parts)))
	  ;; (session:log self "url-path=" url-path " parts=" parts)
	  (if (> numparts 1)
	      (sdat-path-params-set! self (cdr parts)))
          (if query-string
              (sdat-params-set! self (string-split query-string "&")))))))

;; BUGGY!
(define (session:get-new-key self)
  (let ((conn   (sdat-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))

(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)
    ;;                        (sdat-conn self))
    ;;                        conn)
    (dbi:for-each-row (lambda (tuple)
			(set! result (vector-ref tuple 0))) ;; (vector-ref tuple 0)))
		      (sdat-conn self)
		      (s:sqlparam query session-key))
    result))

;; delete all records for a session
;; 
;; NEEDS TO BE TRANSACTIONIZED!
;;
(define (session:delete-session self session-key)
  (let ((session-id (session:get-session-id self session-key))
        (qry1        ;; (conc "BEGIN;"
			  "DELETE FROM session_vars WHERE session_id=?;")
	(qry2             "DELETE FROM sessions WHERE id=?;")
		     ;;  "COMMIT;"))
        (conn              (sdat-conn self)))
    (if session-id
        (begin
          (dbi:exec conn qry1 session-id) ;; session-id)
	  (dbi:exec conn qry2 session-id)
	  ;; (session:initialize self)
	  (session:setup self)))
    (not (session:get-session-id self 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              (sdat-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 (session:extract-key self key)
  (let ((params (sdat-params self)))
    (session:extract-key-from-param self params key)))

(define (session:extract-key-from-param self params key)
  (let ((r1     (regexp (string-append "^" key "=([^=]+)$"))))
    (err:log "INFO: Looking for " key " in " params)
    (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)))
		(err:log "INFO: Found session key=" session-key)
		(sdat-session-key-set! self (list-ref match 1))
		session-key))
	     ((null? tail)
	      #f)
	     (else
	      (loop (car tail)
		    (cdr tail)))))))))

(define (session:set-page! self page_name)
  (sdat-page-set! self page_name))

(define (session:close self)
  (dbi:close (sdat-conn self)))
;; (close-output-port (sdat-logpt self))

(define (session:err-msg self msg)
  (hash-table-set! (sdat-sessionvars self) "ERROR_MSG"
		   (string-intersperse (map s:any->string msg) " ")))

(define (session:prev-err self)
  (let ((prev-err (hash-table-ref/default (sdat-sessionvars-before self) "ERROR_MSG" #f))
	(curr-err (hash-table-ref/default (sdat-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 (session:curr-page-set! self key value)
  (hash-table-set! (sdat-pagevars self) (s:any->string key) (s:any->string value)))

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

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

;; set a session var for a given page
;;
(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 (session:page-get self key)
  (hash-table-ref/default (sdat-pagevars self) key #f))

;; get session vars for a specified page
;;
(define (session:get self page key params)
  (let* ((ht  (session:get-page-hash self page))
	 (res (hash-table-ref/default ht (s:any->string key) #f)))
    (session:apply-type-preference res params)))

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

;; get ALL keys for this page and store in the session pagevars hash
;;
(define (session:get-vars self)
  (let ((session-id  (sdat-session-id self)))
    (if (not session-id)
	(err:log "ERROR: No session id in session object! session:get-vars")
	(let* ((result             #f)
	       (conn               (sdat-conn self))
	       (pagevars-before    (sdat-pagevars-before self))
	       (sessionvars-before (sdat-sessionvars-before self))
	       (globalvars-before  (sdat-globalvars-before self))
	       (pagevars           (sdat-pagevars self))
	       (sessionvars        (sdat-sessionvars self))
	       (globalvars         (sdat-globalvars self))
	       (page-name          (sdat-page self))
	       (session-key        (sdat-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)))

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

(define (session:save-vars self)
  (let ((session-id  (sdat-session-id self)))
    (if (not session-id)
	(err:log "ERROR: No session id in session object! session:get-vars")
	(let* ((status      #f)
	       (conn        (sdat-conn self))
	       (page-name   (sdat-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* ((before-after-ht (cond
				      ((string=? page "*sessionvars*")
				       (vector (sdat-sessionvars self)
					       (sdat-sessionvars-before self)))
				       ((string=? page "*globalvars*")
					(vector (sdat-globalvars self)
						(sdat-globalvars-before self)))
				       (else 
					(vector (sdat-pagevars self)
						(sdat-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)

;;  'flat     => pages flat directory
;;  'dir      => directory tree pages/<pagename>/{view,control}.scm
;; parts:
;;  'both     => load control and view (anything other than view or control and the default)
;;  'view     => load view only
;;  'control  => load control only
(define (session:call-parts self page #!key (parts 'both))
  (sdat-curr-page-set! self page)
  (let* ((dir-style    (sdat-page-dir-style self));; (equal? (sdat-page-dir-style self) "onedir")) ;; flag #t for onedir, #f for old style
	 (dir          (string-append (sdat-sroot self) 
				      (if dir-style 
					  (conc "/pages/")
					  (conc "/pages/" page)))))
    (case dir-style
      ;; NB// Stored always loads both control and view
      ((stored)
       ((eval (string->symbol (conc "pages:" page))) 
	self                         ;; the session
	(sdat-conn self)         ;; the db connection
	(sdat-shared-hash self)  ;; a shared hash table for passing data to/from page calls
	))
      ((flat)   
       (let* ((so-file  (conc dir page ".so"))
	      (scm-file (conc dir page ".scm"))
	      (src-file (or (file-exists? so-file)
			    (file-exists? scm-file))))
	 (if src-file
	     (begin
	       (load src-file)
	       ((eval (string->symbol (conc "pages:" page))) 
		self                         ;; the session
		(sdat-conn self)         ;; the db connection
		(sdat-shared-hash self)  ;; a shared hash table for passing data to/from page calls
		))
	     (list "<p>Page not found " page " </p>"))))
       ;; first the control
       ;; (let ((control-file (conc "pages/" page "_ctrl.scm"))
       ;;       (view-file    (conc "pages/" page "_view.scm")))
       ;;   (if (and (file-exists? control-file)
       ;;  	  (not (eq? parts 'view)))

      (else
       (list "ERROR: page-dir-style must be stored, dir or flat, got " dir-style)))))

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

;; (define (session:load-model self model)
;;   (let ((model.scm (string-append (sdat-sroot self) "/models/" model ".scm"))
;; 	(model.so  (string-append (sdat-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 (session:model-path self model)
;;   (string-append (sdat-sroot self) "/models/" model ".scm"))

(define (session:pp-formdat self)
  (let ((dat (formdat:all->strings (sdat-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 (session:link-to self page params)
  (let* ((https-host   (get-environment-variable "HTTPS_HOST"))
         (force-ssl    (sdat-force-ssl self))
	 (server       (or https-host ;; Assuming HTTPS_HOST is only set if available
			   (get-environment-variable "HTTP_HOST")
			   (get-environment-variable "SERVER_NAME")
			   (sdat-domain self)))
         (force-script  (sdat-script self))
	 (script        (or force-script
			    (let ((script-name (string-split (get-environment-variable "SCRIPT_NAME") "/")))
			      (if (> (length script-name) 1)
				  (string-append (car script-name) "/" (cadr script-name))
				  (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-session-key self))
	 (paramstr      (session:param->string params)))
    (session:log self "server=" server " script=" script " page=" page)
    (string-append (if (or https-host force-ssl)
		      "https://"
		      "http://")
		   server "/" script "/" page "?" paramstr))) ;; "/sn=" session-key)))

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

(define (session:log self . msg)
  (with-output-to-port (sdat-log-port self) ;; (sdat-logpt self)
    (lambda () 
      (apply print msg))))

;; escape, convert or return raw when given user input data that potentially
;; could be malicious
;;
(define (session:apply-type-preference res params)

                (if (null? tail) #f
                    (loop (car tail)(cdr tail)))))))))

;; params are stored as list of key=val
;;
(define (session:get-param self key type-params)
  ;; (session:log s:session "params=" (slot-ref s:session 'params))
  (let* ((params (sdat-params self))
	 (res    (session:get-param-from params key)))
    (session:apply-type-preference res type-params)))

;; This one will get the first value found regardless of form
;; param: (dtype [tag1 tag2 ...])
;; dtype:
;;    'raw     : do no conversion
;;    'number  : convert to number, return #f if fails
;;    'escaped : use html-escape to protect the input -- this is the default
;;
(define (session:get-input self key params)
  (let* ((dtype    (if (null? params)
		       'escaped
		       (car params)))
	 (tags    (if (null? params)
		      '()
		      (cdr params)))
	 (formdat (sdat-formdat self))
	 (res     (if (not formdat) #f
		      (if (or (string? key)(number? key)(symbol? key))
			  (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))

		     res))
      (else      (if (string? res)
		     (s:html-filter->string res '())
		     res)))))

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

(define (session:run-actions self)
  (let* ((action    (session:get-param self 'action '(raw)))
	 (page      (sdat-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))

				    ((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 (session:never-called-page? self page)
  (session:log self "Checking for page: " page)
  (not (member page (sdat-seen-pages self))))

(define (session:set-called! self page)
  (sdat-seen-pages-set! self (cons page (sdat-seen-pages self))))

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

(define (session:alt-out self)
  (let ((dat (sdat-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: " (sdat-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 "")

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


;; Usage: (s:get-err s:big)
(define (s:get-err wrapperfunc)
  (let ((errmsg (sdat-curr-err s:session)))
    (if errmsg ((if wrapperfunc
                    wrapperfunc
                    s:strong) errmsg) '())))
(define (stml:cgi-session session)
  ;; (session:initialize session)
  (session:setup session)
  (session:get-vars session)

  (sdat-log-port-set! session ;; (current-error-port))
		      (open-output-file (sdat-logfile session) #:append))
  (s:validate-inputs)
  (session:run-actions session)
  (sdat-pagedat-set! session
		     (append (sdat-pagedat session)
			     (s:call (sdat-toppage session))))
  (if (eq? (sdat-page-type session) 'html) ;; default is html. 
      (session:cgi-out session)
      (session:alt-out session))
  (session:save-vars session)
  (session:close session))


(define (s:validate-inputs)

			     (s:h1 "ERROR")
			     (s:p err)))))))           


(define (stml:main proc)
  (handle-exceptions
   exn   
   (if (sdat-debug-mode s:session)
       (begin
	 (print "Content-type: text/html")
	 (print "")
	 (print "<html> <head> <title>EXCEPTION</title> </head> <body>")
	 (print "   QUERY_STRING is: <b> " (get-environment-variable "QUERY_STRING") " </b> <br>")
	 (print "<pre>")
	 ;; (print "   EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))

			 (print (car var) "\t" (cdr var)))
		       (get-environment-variables))))
	 ;; return something useful to the user
	 (print "Content-type: text/html")
	 (print "")
	 (print "<html> <head> <title>EXCEPTION</title> </head> <body>")
	 (print "<h1>CRASH!</h1>")
	 (print "   Please notify support at " (sdat-domain s:session) " that the error log is stml-crash-" (current-process-id) ".log</b> <br>")
	 ;; (print "<pre>")
	 ;; ;; (print "   EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
	 ;; ;; (print-error-message exn)
	 ;; ;; (print-call-chain)
	 ;; (print "</pre>")
	 ;; (print "<table>")
	 ;; (for-each (lambda (var)
	 ;; 	     (print "<tr><td>" (car var) "</td><td>" (cdr var) "</td></tr>"))
	 ;; 	   (get-environment-variables))
	 ;; (print "</table>")
	 (print "</body></html>")))
   (if proc (proc s:session) (stml:cgi-session s:session))
 ;; (raise-error)
 ;; (exit)
   ))

;; find out if we are in debugmode
(define (s:debug-mode?)
  (sdat-debug-mode s:session))

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

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

(define (s:current-page)
  (sdat-page s:session))

(define (s:delete-session)
  (session:delete-session s:session (sdat-session-key s:session)))

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

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

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

(define s:session-var-delete! s:session-var-del!)

;; utility to get all vars as hash table
(define (s:session-get-sessionvars)
  (sdat-sessionvars s:session))

)