Index: session.scm ================================================================== --- session.scm +++ session.scm @@ -21,77 +21,77 @@ ;; 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-session:sdat)(make-vector 33)) -(define-inline (session:sdat-get-dbtype vec) (vector-ref vec 0)) -(define-inline (session:sdat-get-dbinit vec) (vector-ref vec 1)) -(define-inline (session:sdat-get-conn vec) (vector-ref vec 2)) -(define-inline (session:sdat-get-params vec) (vector-ref vec 3)) -(define-inline (session:sdat-get-path-params vec) (vector-ref vec 4)) -(define-inline (session:sdat-get-session-key vec) (vector-ref vec 5)) -(define-inline (session:sdat-get-session-id vec) (vector-ref vec 6)) -(define-inline (session:sdat-get-domain vec) (vector-ref vec 7)) -(define-inline (session:sdat-get-toppage vec) (vector-ref vec 8)) -(define-inline (session:sdat-get-page vec) (vector-ref vec 9)) -(define-inline (session:sdat-get-curr-page vec) (vector-ref vec 10)) -(define-inline (session:sdat-get-content-type vec) (vector-ref vec 11)) -(define-inline (session:sdat-get-page-type vec) (vector-ref vec 12)) -(define-inline (session:sdat-get-sroot vec) (vector-ref vec 13)) -(define-inline (session:sdat-get-twikidir vec) (vector-ref vec 14)) -(define-inline (session:sdat-get-pagedat vec) (vector-ref vec 15)) -(define-inline (session:sdat-get-alt-page-dat vec) (vector-ref vec 16)) -(define-inline (session:sdat-get-pagevars vec) (vector-ref vec 17)) -(define-inline (session:sdat-get-pagevars-before vec) (vector-ref vec 18)) -(define-inline (session:sdat-get-sessionvars vec) (vector-ref vec 19)) -(define-inline (session:sdat-get-sessionvars-before vec) (vector-ref vec 20)) -(define-inline (session:sdat-get-globalvars vec) (vector-ref vec 21)) -(define-inline (session:sdat-get-globalvars-before vec) (vector-ref vec 22)) -(define-inline (session:sdat-get-logpt vec) (vector-ref vec 23)) -(define-inline (session:sdat-get-formdat vec) (vector-ref vec 24)) -(define-inline (session:sdat-get-request-method vec) (vector-ref vec 25)) -(define-inline (session:sdat-get-session-cookie vec) (vector-ref vec 26)) -(define-inline (session:sdat-get-curr-err vec) (vector-ref vec 27)) -(define-inline (session:sdat-get-log-port vec) (vector-ref vec 28)) -(define-inline (session:sdat-get-logfile vec) (vector-ref vec 29)) -(define-inline (session:sdat-get-seen-pages vec) (vector-ref vec 30)) -(define-inline (session:sdat-get-page-dir-style vec) (vector-ref vec 31)) -(define-inline (session:sdat-get-debugmode vec) (vector-ref vec 32)) -(define-inline (session:sdat-set-dbtype! vec val)(vector-set! vec 0 val)) -(define-inline (session:sdat-set-dbinit! vec val)(vector-set! vec 1 val)) -(define-inline (session:sdat-set-conn! vec val)(vector-set! vec 2 val)) -(define-inline (session:sdat-set-params! vec val)(vector-set! vec 3 val)) -(define-inline (session:sdat-set-path-params! vec val)(vector-set! vec 4 val)) -(define-inline (session:sdat-set-session-key! vec val)(vector-set! vec 5 val)) -(define-inline (session:sdat-set-session-id! vec val)(vector-set! vec 6 val)) -(define-inline (session:sdat-set-domain! vec val)(vector-set! vec 7 val)) -(define-inline (session:sdat-set-toppage! vec val)(vector-set! vec 8 val)) -(define-inline (session:sdat-set-page! vec val)(vector-set! vec 9 val)) -(define-inline (session:sdat-set-curr-page! vec val)(vector-set! vec 10 val)) -(define-inline (session:sdat-set-content-type! vec val)(vector-set! vec 11 val)) -(define-inline (session:sdat-set-page-type! vec val)(vector-set! vec 12 val)) -(define-inline (session:sdat-set-sroot! vec val)(vector-set! vec 13 val)) -(define-inline (session:sdat-set-twikidir! vec val)(vector-set! vec 14 val)) -(define-inline (session:sdat-set-pagedat! vec val)(vector-set! vec 15 val)) -(define-inline (session:sdat-set-alt-page-dat! vec val)(vector-set! vec 16 val)) -(define-inline (session:sdat-set-pagevars! vec val)(vector-set! vec 17 val)) -(define-inline (session:sdat-set-pagevars-before! vec val)(vector-set! vec 18 val)) -(define-inline (session:sdat-set-sessionvars! vec val)(vector-set! vec 19 val)) -(define-inline (session:sdat-set-sessionvars-before! vec val)(vector-set! vec 20 val)) -(define-inline (session:sdat-set-globalvars! vec val)(vector-set! vec 21 val)) -(define-inline (session:sdat-set-globalvars-before! vec val)(vector-set! vec 22 val)) -(define-inline (session:sdat-set-logpt! vec val)(vector-set! vec 23 val)) -(define-inline (session:sdat-set-formdat! vec val)(vector-set! vec 24 val)) -(define-inline (session:sdat-set-request-method! vec val)(vector-set! vec 25 val)) -(define-inline (session:sdat-set-session-cookie! vec val)(vector-set! vec 26 val)) -(define-inline (session:sdat-set-curr-err! vec val)(vector-set! vec 27 val)) -(define-inline (session:sdat-set-log-port! vec val)(vector-set! vec 28 val)) -(define-inline (session:sdat-set-logfile! vec val)(vector-set! vec 29 val)) -(define-inline (session:sdat-set-seen-pages! vec val)(vector-set! vec 30 val)) -(define-inline (session:sdat-set-page-dir-style! vec val)(vector-set! vec 31 val)) -(define-inline (session:sdat-set-debugmode! vec val)(vector-set! vec 32 val)) +(define (make-sdat)(make-vector 33)) +(define-inline (sdat-get-dbtype vec) (vector-ref vec 0)) +(define-inline (sdat-get-dbinit vec) (vector-ref vec 1)) +(define-inline (sdat-get-conn vec) (vector-ref vec 2)) +(define-inline (sdat-get-params vec) (vector-ref vec 3)) +(define-inline (sdat-get-path-params vec) (vector-ref vec 4)) +(define-inline (sdat-get-session-key vec) (vector-ref vec 5)) +(define-inline (sdat-get-session-id vec) (vector-ref vec 6)) +(define-inline (sdat-get-domain vec) (vector-ref vec 7)) +(define-inline (sdat-get-toppage vec) (vector-ref vec 8)) +(define-inline (sdat-get-page vec) (vector-ref vec 9)) +(define-inline (sdat-get-curr-page vec) (vector-ref vec 10)) +(define-inline (sdat-get-content-type vec) (vector-ref vec 11)) +(define-inline (sdat-get-page-type vec) (vector-ref vec 12)) +(define-inline (sdat-get-sroot vec) (vector-ref vec 13)) +(define-inline (sdat-get-twikidir vec) (vector-ref vec 14)) +(define-inline (sdat-get-pagedat vec) (vector-ref vec 15)) +(define-inline (sdat-get-alt-page-dat vec) (vector-ref vec 16)) +(define-inline (sdat-get-pagevars vec) (vector-ref vec 17)) +(define-inline (sdat-get-pagevars-before vec) (vector-ref vec 18)) +(define-inline (sdat-get-sessionvars vec) (vector-ref vec 19)) +(define-inline (sdat-get-sessionvars-before vec) (vector-ref vec 20)) +(define-inline (sdat-get-globalvars vec) (vector-ref vec 21)) +(define-inline (sdat-get-globalvars-before vec) (vector-ref vec 22)) +(define-inline (sdat-get-logpt vec) (vector-ref vec 23)) +(define-inline (sdat-get-formdat vec) (vector-ref vec 24)) +(define-inline (sdat-get-request-method vec) (vector-ref vec 25)) +(define-inline (sdat-get-session-cookie vec) (vector-ref vec 26)) +(define-inline (sdat-get-curr-err vec) (vector-ref vec 27)) +(define-inline (sdat-get-log-port vec) (vector-ref vec 28)) +(define-inline (sdat-get-logfile vec) (vector-ref vec 29)) +(define-inline (sdat-get-seen-pages vec) (vector-ref vec 30)) +(define-inline (sdat-get-page-dir-style vec) (vector-ref vec 31)) +(define-inline (sdat-get-debugmode vec) (vector-ref vec 32)) +(define-inline (sdat-set-dbtype! vec val)(vector-set! vec 0 val)) +(define-inline (sdat-set-dbinit! vec val)(vector-set! vec 1 val)) +(define-inline (sdat-set-conn! vec val)(vector-set! vec 2 val)) +(define-inline (sdat-set-params! vec val)(vector-set! vec 3 val)) +(define-inline (sdat-set-path-params! vec val)(vector-set! vec 4 val)) +(define-inline (sdat-set-session-key! vec val)(vector-set! vec 5 val)) +(define-inline (sdat-set-session-id! vec val)(vector-set! vec 6 val)) +(define-inline (sdat-set-domain! vec val)(vector-set! vec 7 val)) +(define-inline (sdat-set-toppage! vec val)(vector-set! vec 8 val)) +(define-inline (sdat-set-page! vec val)(vector-set! vec 9 val)) +(define-inline (sdat-set-curr-page! vec val)(vector-set! vec 10 val)) +(define-inline (sdat-set-content-type! vec val)(vector-set! vec 11 val)) +(define-inline (sdat-set-page-type! vec val)(vector-set! vec 12 val)) +(define-inline (sdat-set-sroot! vec val)(vector-set! vec 13 val)) +(define-inline (sdat-set-twikidir! vec val)(vector-set! vec 14 val)) +(define-inline (sdat-set-pagedat! vec val)(vector-set! vec 15 val)) +(define-inline (sdat-set-alt-page-dat! vec val)(vector-set! vec 16 val)) +(define-inline (sdat-set-pagevars! vec val)(vector-set! vec 17 val)) +(define-inline (sdat-set-pagevars-before! vec val)(vector-set! vec 18 val)) +(define-inline (sdat-set-sessionvars! vec val)(vector-set! vec 19 val)) +(define-inline (sdat-set-sessionvars-before! vec val)(vector-set! vec 20 val)) +(define-inline (sdat-set-globalvars! vec val)(vector-set! vec 21 val)) +(define-inline (sdat-set-globalvars-before! vec val)(vector-set! vec 22 val)) +(define-inline (sdat-set-logpt! vec val)(vector-set! vec 23 val)) +(define-inline (sdat-set-formdat! vec val)(vector-set! vec 24 val)) +(define-inline (sdat-set-request-method! vec val)(vector-set! vec 25 val)) +(define-inline (sdat-set-session-cookie! vec val)(vector-set! vec 26 val)) +(define-inline (sdat-set-curr-err! vec val)(vector-set! vec 27 val)) +(define-inline (sdat-set-log-port! vec val)(vector-set! vec 28 val)) +(define-inline (sdat-set-logfile! vec val)(vector-set! vec 29 val)) +(define-inline (sdat-set-seen-pages! vec val)(vector-set! vec 30 val)) +(define-inline (sdat-set-page-dir-style! vec val)(vector-set! vec 31 val)) +(define-inline (sdat-set-debugmode! vec val)(vector-set! vec 32 val)) ;; (define-class () ;; (dbtype ;; 'pg or 'sqlite3 ;; dbinit ;; conn @@ -126,107 +126,121 @@ ;; page-dir-style ;; #t = new style, #f = old style ;; debugmode)) ;; SPLIT INTO STRAIGHT FORWARD INIT AND COMPLEX INIT (define (initialize self) - (session:sdat-set-dbtype! self 'pg) - (session:sdat-set-page! self "home") ;; these are defaults - (session:sdat-set-curr-page! self "home") - (session:sdat-set-content-type! self "Content-type: text/html; charset=iso-8859-1\n\n") - (session:sdat-set-page-type! self 'html) - (session:sdat-set-toppage! self "index") - (session:sdat-set-params! self '()) ;; - (session:sdat-set-path-params! self '()) - (session:sdat-set-session-key! self #f) - (session:sdat-set-pagedat! self '()) - (session:sdat-set-alt-page-dat! self #f) - (session:sdat-set-sroot! self "./") - (session:sdat-set-session-cookie! self #f) - (session:sdat-set-curr-err! self #f) - (session:sdat-set-log-port! self (current-error-port)) - (session:sdat-set-seen-pages! self '()) - (session:sdat-set-page-dir-style! self #t) ;; #t : pages/_(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/_(view|cntl).scm ;; #f : pages//(view|control).scm - (session:sdat-set-debugmode! self #f) - (for-each (lambda (slot-name) - (session:sdat-set-lot-name! self (make-hash-table))) - (list 'pagevars 'sessionvars 'globalvars 'pagevars-before - 'sessionvars-before 'globalvars-before)) - (session:sdat-set-domain! self "locahost") ;; end of defaults - (initialize-slots self (session:read-config self)) - - ;; FIXME - NOT AUTOMATICALLY TRANSLATED - ;; some values read in from the config file need to be evaled - (session:sdat-set-dbtype! self (eval (session:sdat-get-dbtype self)))) - + (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)) + (logfile (s:find-param 'logfile configdat)) + (dbtype (s:find-param 'dbtype configdat)) + (dbinit (s:find-param 'dbinit configdat)) + (domain (s:find-param 'domain configdat))) + (print "configdat: ")(pp configdat) + (print "sroot: " sroot " logfile: " logfile " dbtype: " dbtype " dbinit: " dbinit " domain: " domain) + (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)))) +;; (let ((dbtype (sdat-get-dbtype self))) +;; (print "dbtype: " dbtype) +;; (sdat-set-dbtype! self (eval dbtype)))) (define (session:setup self) - (let ((dbtype (session:sdat-get-dbtype self)) - (dbinit (eval (session:sdat-get-dbinit 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)) ) - (session:sdat-set-conn! self (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 - (session:sdat-set-request-method! self (getenv "REQUEST_METHOD")) - (session:sdat-set-formdat! self (formdat:load-all)))) + (sdat-set-request-method! self (getenv "REQUEST_METHOD")) + (sdat-set-formdat! self (formdat:load-all)))) ;; setup the db with session tables, works for sqlite only right now (define (session:setup-db self) - (let ((conn (session:sdat-get-conn 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 -;; (session:sdat-set-session-id! self (session:get-id self))) +;; (sdat-set-session-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))) - (session:sdat-set-session-key! self new-key) - (session:sdat-set-session-id! self new-sid) - (session:sdat-set-session-cookie! self (session:make-cookie self))) - (session:sdat-set-session-id! self 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 (session:make-cookie self) - ;; (list (conc "session_key=" (session:sdat-get-session-key self) "; Path=/; Domain=." (session:sdat-get-domain self) "; Max-Age=" (* 86400 14) "; Version=1"))) + ;; (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" ,(session:sdat-get-session-key self) + `(("session_key" ,(sdat-get-session-key self) expires: ,(+ (current-seconds) (* 14 86400)) max-age: (* 14 86400) path: "/" ;; - domain: ,(string-append "." (session:sdat-get-domain self)) + 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 (session:get-id self session-key) - ;; (let ((session-key (session:sdat-get-session-key self))) + ;; (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 (session:sdat-get-conn self)) + (conn (sdat-get-conn self)) (result #f)) (dbi:for-each-row (lambda (tuple) (set! result (vector-ref tuple 0))) conn query) @@ -241,20 +255,20 @@ ;; (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) - (session:sdat-set-page! self (car parts))) + (sdat-set-page! self (car parts))) ;; (session:log self "url-path=" url-path " parts=" parts) (if (> numparts 1) - (session:sdat-set-path-params! self (cdr parts))) + (sdat-set-path-params! self (cdr parts))) (if query-string - (session:sdat-set-params! self (string-split query-string "&"))))))) + (sdat-set-params! self (string-split query-string "&"))))))) ;; BUGGY! (define (session:get-new-key self) - (let ((conn (session:sdat-get-conn 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 "')")) @@ -271,15 +285,15 @@ (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) - ;; (session:sdat-get-conn self)) + ;; (sdat-get-conn self)) ;; conn) (dbi:for-each-row (lambda (tuple) (set! result (vector-ref tuple 0))) ;; (vector-ref tuple 0))) - (session:sdat-get-conn self) + (sdat-get-conn self) (s:sqlparam query session-key)) result)) ;; delete all records for a session ;; @@ -287,11 +301,11 @@ (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 (session:sdat-get-conn self))) + (conn (sdat-get-conn self))) (if session-id (begin (dbi:exec conn qry session-id session-id) (initialize self '()) (session:setup self))) @@ -301,11 +315,11 @@ ;; (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 (session:sdat-get-conn self))) +;; (conn (sdat-get-conn self))) ;; (if session-id ;; (begin ;; (for-each ;; (lambda (query) ;; (dbi:exec conn query session-id)) @@ -313,11 +327,11 @@ ;; (initialize self '()) ;; (session:setup self))) ;; (not (session:get-session-id self session-key)))) (define (session:extract-key self key) - (let ((params (session:sdat-get-params self))) + (let ((params (sdat-get-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 "=([^=]+)$")))) (if (< (length params) 1) #f @@ -325,32 +339,32 @@ (tail (cdr params))) (let ((match (string-match r1 head))) (cond (match (let ((session-key (list-ref match 1))) - (session:sdat-set-session-key! self (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 (session:set-page! self page_name) - (session:sdat-set-page! self page_name)) + (sdat-set-page! self page_name)) (define (session:close self) - (dbi:close (session:sdat-get-conn self))) -;; (close-output-port (session:sdat-get-logpt self)) + (dbi:close (sdat-get-conn self))) +;; (close-output-port (sdat-get-logpt self)) (define (session:err-msg self msg) - (hash-table-set! (session:sdat-get-sessionvars self) "ERROR_MSG" + (hash-table-set! (sdat-get-sessionvars self) "ERROR_MSG" (string-intersperse (map s:any->string msg) " "))) (define (session:prev-err self) - (let ((prev-err (hash-table-ref/default (session:sdat-get-sessionvars-before self) "ERROR_MSG" #f)) - (curr-err (hash-table-ref/default (session:sdat-get-sessionvars self) "ERROR_MSG" #f))) + (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 @@ -358,25 +372,25 @@ ;; consuming function (at least for now, I'd like to change this) ;; set a session var for the current page ;; (define (session:set! self key value) - (hash-table-set! (session:sdat-get-pagevars self) (s:any->string key) (s:any->string value))) + (hash-table-set! (sdat-get-pagevars self) (s:any->string key) (s:any->string value))) ;; del a var for the current page ;; (define (session:del! self key) - (hash-table-delete! (session:sdat-get-pagevars self) (s:any->string key))) + (hash-table-delete! (sdat-get-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*") - (session:sdat-get-sessionvars self) + (sdat-get-sessionvars self) (if (string=? page "*globalvars*") - (session:sdat-get-globalvars self) - (session:sdat-get-pagevars self)))) + (sdat-get-globalvars self) + (sdat-get-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))) @@ -383,11 +397,11 @@ (hash-table-set! ht (s:any->string key) (s:any->string value)))) ;; get session vars for the current page ;; (define (session:get self key) - (hash-table-ref/default (session:sdat-get-pagevars self) key #f)) + (hash-table-ref/default (sdat-get-pagevars self) key #f)) ;; get session vars for a specified page ;; (define (session:get self page key) (let ((ht (session:get-page-hash self page))) @@ -400,23 +414,23 @@ (hash-table-delete! ht key))) ;; get ALL keys for this page and store in the session pagevars hash ;; (define (session:get-vars self) - (let ((session-id (session:sdat-get-session-id 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 (session:sdat-get-conn self)) - (pagevars-before (session:sdat-get-pagevars-before self)) - (sessionvars-before (session:sdat-get-sessionvars-before self)) - (globalvars-before (session:sdat-get-globalvars-before self)) - (pagevars (session:sdat-get-pagevars self)) - (sessionvars (session:sdat-get-sessionvars self)) - (globalvars (session:sdat-get-globalvars self)) - (page-name (session:sdat-get-page self)) - (session-key (session:sdat-get-session-key self)) + (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) @@ -443,16 +457,16 @@ conn (s:sqlparam query session-key "*globalvars")) )))) (define (session:save-vars self) - (let ((session-id (session:sdat-get-session-id 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 (session:sdat-get-conn self)) - (page-name (session:sdat-get-page self)) + (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 @@ -462,12 +476,12 @@ ((string=? page "*sessionvars*") 'sessionvars) ((string=? page "*globalvars*") 'globalvars) (else 'pagevars))) (before-slot-name (string->symbol (string-append (symbol->string master-slot-name) "-before"))) - (master-ht (session:sdat-get-aster-slot-name self)) - (before-ht (session:sdat-get-efore-slot-name self)) + (master-ht (sdat-get-aster-slot-name self)) + (before-ht (sdat-get-efore-slot-name self)) (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) @@ -565,15 +579,15 @@ ;; 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 (session:call-parts self page parts) - (session:sdat-set-curr-page! self page) - ;; (session:log self "page-dir-style: " (session:sdat-get-page-dir-style self)) - (let* ((dir-style ;; (equal? (session:sdat-get-page-dir-style self) "onedir")) ;; flag #t for onedir, #f for old style - (session:sdat-get-page-dir-style self)) - (dir (string-append (session:sdat-get-sroot self) + (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") @@ -631,23 +645,23 @@ (define (session:call self page parts) (session:call-parts self page 'both)) (define (session:load-model self model) - (let ((model.scm (string-append (session:sdat-get-sroot self) "/models/" model ".scm")) - (model.so (string-append (session:sdat-get-sroot self) "/models/" model ".so"))) + (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 (session:model-path self model) - (string-append (session:sdat-get-sroot self) "/models/" model ".scm")) + (string-append (sdat-get-sroot self) "/models/" model ".scm")) (define (session:pp-formdat self) - (let ((dat (formdat:all->strings (session:sdat-get-formdat self)))) + (let ((dat (formdat:all->strings (sdat-get-formdat self)))) (string-intersperse dat "
"))) (define (session:param->string params) ;; (err:log "params=" params) (if (< (length params) 1) @@ -668,39 +682,39 @@ (getenv "SERVER_NAME"))) (script (let ((script-name (string-split (getenv "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 (session:sdat-get-session-key self)) + (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 (session:cgi-out self) - (let* ((content (list (session:sdat-get-content-type self))) ;; '("Content-type: text/html; charset=iso-8859-1\n\n")) - (header (let ((cookie (session:sdat-get-session-cookie 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 (session:sdat-get-pagedat self))) + (pagedat (sdat-get-pagedat self))) (s:cgi-out (cons header pagedat)))) (define (session:log self . msg) - (with-output-to-port (session:sdat-get-log-port self) ;; (session:sdat-get-logpt self) + (with-output-to-port (sdat-get-log-port self) ;; (sdat-get-logpt self) (lambda () (apply print msg)))) (define (session:get-param self key) ;; (session:log s:session "params=" (slot-ref s:session 'params)) - (let ((params (session:sdat-get-params self))) + (let ((params (sdat-get-params self))) (session:get-param-from params key))) ;; This one will get the first value found regardless of form (define (session:get-input self key) - (let* ((formdat (session:sdat-get-formdat self))) + (let* ((formdat (sdat-get-formdat self))) (if (not formdat) #f (if (or (string? key)(number? key)(symbol? key)) (if (eq? (class-of formdat) ) (formdat:get formdat key) (begin @@ -708,11 +722,11 @@ #f)) (session:log self "ERROR: bad key " key))))) (define (session:run-actions self) (let* ((action (session:get-param self 'action)) - (page (session:sdat-get-page self))) + (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)) @@ -735,28 +749,28 @@ ((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 (session:sdat-get-seen-pages self)))) + (not (member page (sdat-get-seen-pages self)))) (define (session:set-called! self page) - (session:sdat-set-seen-pages! self (cons page (session:sdat-get-seen-pages self)))) + (sdat-set-seen-pages! self (cons page (sdat-get-seen-pages self)))) ;;====================================================================== ;; Alternative data type delivery ;;====================================================================== (define (session:alt-out self) - (let ((dat (session:sdat-get-alt-page-dat 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: " (session:sdat-get-content-type self)) + (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)))) Index: setup.scm ================================================================== --- setup.scm +++ setup.scm @@ -6,11 +6,12 @@ ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;; -(define s:session (make )) +(define s:session (make-sdat)) +(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)) @@ -26,24 +27,24 @@ (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-sesson-key s:session))) (define (s:call page . partsl) (if (null? partsl) (session:call s:session page) (session:call s:session page (car partsl)))) @@ -93,10 +94,10 @@ (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)) Index: tests/test.scm ================================================================== --- tests/test.scm +++ tests/test.scm @@ -8,18 +8,22 @@ ;; 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) (load "./requirements.scm") (load "./misc-stml.scm") (load "./formdat.scm") (load "./stml.scm") (load "./session.scm") -(load "./sqltbl.scm") +;(load "./sqltbl.scm") (load "./html-filter.scm") (load "./keystore.scm") ;; Test the primitive dbi interface