Index: stml2.scm ================================================================== --- stml2.scm +++ stml2.scm @@ -14,14 +14,82 @@ (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:)) +(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) @@ -145,11 +213,11 @@ ;; 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-get-page s:session))) + (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: @@ -403,31 +471,31 @@ ;; share data between pages calls. NOTE: This is not persistent ;; between cgi calls. Use sessionvars for that. ;; (define (s:shared-hash) - (sdat-get-shared-hash s:session)) + (sdat-shared-hash s:session)) (define (s:shared-set! key val) - (hash-table-set! (sdat-get-shared-hash s:session) 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-get-shared-hash s:session) key #f)) + (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-get-path-params s:session)) + (sdat-path-params s:session)) (define (s:get-path-params) - (sdat-get-path-params s:session)) + (sdat-path-params s:session)) (define (s:db) - (sdat-get-conn s:session)) + (sdat-conn s:session)) ;;====================================================================== ;; cgi and session stuff ;;====================================================================== @@ -1438,126 +1506,126 @@ ;; 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-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-pgconn vec) (vector-ref (vector-ref vec 2) 1)) -(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-get-shared-hash vec) (vector-ref vec 33)) -(define (sdat-get-script vec) (vector-ref vec 34)) -(define (sdat-get-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-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 (sdat-set-shared-hash! vec val)(vector-set! vec 33 val)) -(define (sdat-set-script! vec val)(vector-set! vec 34 val)) -(define (sdat-set-force-ssl! vec val)(vector-set! vec 35 val)) - -(define (session:set-shared! vec varname val) - (hash-table-set! (vector-ref vec 33) varname val)) +;; (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-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 +#;(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/_(view|cntl).scm ;; #f : pages//(view|control).scm - (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 - (sdat-set-script! self #f) - (sdat-set-force-ssl! self #f) + (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)) @@ -1566,38 +1634,38 @@ (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-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)) - (if debugmode (sdat-set-debugmode! self debugmode)) - (if script (sdat-set-script! self script)) - (if force-ssl (sdat-set-force-ssl! self force-ssl)) - (sdat-set-page-dir-style! self page-dir) + (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-set-shared-hash! self (make-hash-table)) + (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-get-dbtype self))) +;; (let ((dbtype (sdat-dbtype self))) ;; (print "dbtype: " dbtype) -;; (sdat-set-dbtype! self (eval dbtype)))) +;; (sdat-dbtype-set! self (eval dbtype)))) (define (session:setup self) - (let ((dbtype (sdat-get-dbtype self)) - (debugmode (sdat-get-debugmode self)) - (dbinit (eval (sdat-get-dbinit 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 @@ -1612,48 +1680,48 @@ (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-set-conn! self (dbi:open dbtype dbinit)) - (set! *db* (sdat-get-conn self)) + (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-set-request-method! self (get-environment-variable "REQUEST_METHOD")) - (sdat-set-formdat! self (formdat:load-all)))) + (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-get-conn 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-set-session-id! self (session:get-id self))) +;; (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-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)))) + (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-get-session-key self) "; Path=/; Domain=." (sdat-get-domain self) "; Max-Age=" (* 86400 14) "; Version=1"))) + ;; (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 @@ -1674,23 +1742,23 @@ ;; %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-get-session-key self) + `(("session_key" ,(sdat-session-key self) expires: ,(+ (current-seconds) (* 14 86400)) ;; max-age: (* 14 86400) path: "/" ;; - domain: ,(string-append "." (sdat-get-domain self)) + 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-get-session-key self))) + ;; (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-get-conn self)) + (conn (sdat-conn self)) (result #f)) (dbi:for-each-row (lambda (tuple) (set! result (vector-ref tuple 0))) conn query) @@ -1705,20 +1773,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) - (sdat-set-page! self (car parts))) + (sdat-page-set! self (car parts))) ;; (session:log self "url-path=" url-path " parts=" parts) (if (> numparts 1) - (sdat-set-path-params! self (cdr parts))) + (sdat-path-params-set! self (cdr parts))) (if query-string - (sdat-set-params! self (string-split query-string "&"))))))) + (sdat-params-set! self (string-split query-string "&"))))))) ;; BUGGY! (define (session:get-new-key self) - (let ((conn (sdat-get-conn 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 "')")) @@ -1736,15 +1804,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) - ;; (sdat-get-conn self)) + ;; (sdat-conn self)) ;; conn) (dbi:for-each-row (lambda (tuple) (set! result (vector-ref tuple 0))) ;; (vector-ref tuple 0))) - (sdat-get-conn self) + (sdat-conn self) (s:sqlparam query session-key)) result)) ;; delete all records for a session ;; @@ -1754,26 +1822,26 @@ (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-get-conn self))) + (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: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-get-conn self))) +;; (conn (sdat-conn self))) ;; (if session-id ;; (begin ;; (for-each ;; (lambda (query) ;; (dbi:exec conn query session-id)) @@ -1781,11 +1849,11 @@ ;; (initialize self '()) ;; (session:setup self))) ;; (not (session:get-session-id self session-key)))) (define (session:extract-key self key) - (let ((params (sdat-get-params self))) + (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) @@ -1795,32 +1863,32 @@ (let ((match (string-match r1 head))) (cond (match (let ((session-key (list-ref match 1))) (err:log "INFO: Found session key=" session-key) - (sdat-set-session-key! self (list-ref match 1)) + (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-set-page! self page_name)) + (sdat-page-set! self page_name)) (define (session:close self) - (dbi:close (sdat-get-conn self))) -;; (close-output-port (sdat-get-logpt self)) + (dbi:close (sdat-conn self))) +;; (close-output-port (sdat-logpt self)) (define (session:err-msg self msg) - (hash-table-set! (sdat-get-sessionvars self) "ERROR_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-get-sessionvars-before self) "ERROR_MSG" #f)) - (curr-err (hash-table-ref/default (sdat-get-sessionvars self) "ERROR_MSG" #f))) + (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 @@ -1828,25 +1896,25 @@ ;; 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-get-pagevars self) (s:any->string key) (s:any->string 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-get-pagevars self) (s:any->string 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-get-sessionvars self) + (sdat-sessionvars self) (if (string=? page "*globalvars*") - (sdat-get-globalvars self) - (sdat-get-pagevars self)))) + (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))) @@ -1853,11 +1921,11 @@ (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-get-pagevars self) key #f)) + (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)) @@ -1871,23 +1939,23 @@ (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-get-session-id 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-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)) + (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) @@ -1914,33 +1982,33 @@ conn (s:sqlparam query session-key "*globalvars")) )))) (define (session:save-vars self) - (let ((session-id (sdat-get-session-id 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-get-conn self)) - (page-name (sdat-get-page self)) + (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-get-sessionvars self) - (sdat-get-sessionvars-before self))) + (vector (sdat-sessionvars self) + (sdat-sessionvars-before self))) ((string=? page "*globalvars*") - (vector (sdat-get-globalvars self) - (sdat-get-globalvars-before self))) + (vector (sdat-globalvars self) + (sdat-globalvars-before self))) (else - (vector (sdat-get-pagevars self) - (sdat-get-pagevars-before self))))) + (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)))) @@ -2034,23 +2102,23 @@ ;; 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-set-curr-page! self page) - (let* ((dir-style (sdat-get-page-dir-style self));; (equal? (sdat-get-page-dir-style self) "onedir")) ;; flag #t for onedir, #f for old style - (dir (string-append (sdat-get-sroot self) + (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-get-conn self) ;; the db connection - (sdat-get-shared-hash self) ;; a shared hash table for passing data to/from page calls + (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) @@ -2058,12 +2126,12 @@ (if src-file (begin (load src-file) ((eval (string->symbol (conc "pages:" page))) self ;; the session - (sdat-get-conn self) ;; the db connection - (sdat-get-shared-hash self) ;; a shared hash table for passing data to/from page calls + (sdat-conn self) ;; the db connection + (sdat-shared-hash self) ;; a shared hash table for passing data to/from page calls )) (list "

Page not found " page "

")))) ;; first the control ;; (let ((control-file (conc "pages/" page "_ctrl.scm")) ;; (view-file (conc "pages/" page "_view.scm"))) @@ -2082,23 +2150,23 @@ (define (session:call self page parts) (session:call-parts self page 'both)) ;; (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"))) +;; (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-get-sroot self) "/models/" model ".scm")) +;; (string-append (sdat-sroot self) "/models/" model ".scm")) (define (session:pp-formdat self) - (let ((dat (formdat:all->strings (sdat-get-formdat self)))) + (let ((dat (formdat:all->strings (sdat-formdat self)))) (string-intersperse dat "
"))) (define (session:param->string params) ;; (err:log "params=" params) (if (< (length params) 1) @@ -2113,42 +2181,42 @@ (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-get-force-ssl self)) + (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-get-domain self))) - (force-script (sdat-get-script self)) + (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-get-session-key self)) + (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-get-content-type self))) ;; '("Content-type: text/html; charset=iso-8859-1\n\n")) - (header (let ((cookie (sdat-get-session-cookie 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-get-pagedat self))) + (pagedat (sdat-pagedat self))) (s:cgi-out (cons header pagedat)))) (define (session:log self . msg) - (with-output-to-port (sdat-get-log-port self) ;; (sdat-get-logpt self) + (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 @@ -2192,11 +2260,11 @@ ;; 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-get-params self)) + (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 ...]) @@ -2210,11 +2278,11 @@ 'escaped (car params))) (tags (if (null? params) '() (cdr params))) - (formdat (sdat-get-formdat self)) + (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 @@ -2233,21 +2301,21 @@ (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-get-formdat 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 ") #f))))) (define (session:run-actions self) (let* ((action (session:get-param self 'action '(raw))) - (page (sdat-get-page self))) + (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)) @@ -2270,25 +2338,25 @@ ((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-get-seen-pages self)))) + (not (member page (sdat-seen-pages self)))) (define (session:set-called! self page) - (sdat-set-seen-pages! self (cons page (sdat-get-seen-pages self)))) + (sdat-seen-pages-set! self (cons page (sdat-seen-pages self)))) ;;====================================================================== ;; Alternative data type delivery ;;====================================================================== (define (session:alt-out self) - (let ((dat (sdat-get-alt-page-dat 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-get-content-type self)) + (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") @@ -2306,27 +2374,27 @@ (apply session:log s:session msg)) ;; Usage: (s:get-err s:big) (define (s:get-err wrapperfunc) - (let ((errmsg (sdat-get-curr-err s:session))) + (let ((errmsg (sdat-curr-err s:session))) (if errmsg ((if wrapperfunc wrapperfunc s:strong) errmsg) '()))) (define (stml:cgi-session session) - (session:initialize session) + ;; (session:initialize session) (session:setup session) (session:get-vars session) - (sdat-set-log-port! session ;; (current-error-port)) - (open-output-file (sdat-get-logfile session) #:append)) + (sdat-log-port-set! session ;; (current-error-port)) + (open-output-file (sdat-logfile session) #:append)) (s:validate-inputs) (session:run-actions session) - (sdat-set-pagedat! session - (append (sdat-get-pagedat session) - (s:call (sdat-get-toppage session)))) - (if (eq? (sdat-get-page-type session) 'html) ;; default is html. + (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)) @@ -2349,11 +2417,11 @@ (define (stml:main proc) (handle-exceptions exn - (if (sdat-get-debugmode s:session) + (if (sdat-debug-mode s:session) (begin (print "Content-type: text/html") (print "") (print " EXCEPTION ") (print " QUERY_STRING is: " (get-environment-variable "QUERY_STRING") "
") @@ -2384,11 +2452,11 @@ ;; return something useful to the user (print "Content-type: text/html") (print "") (print " EXCEPTION ") (print "

CRASH!

") - (print " Please notify support at " (sdat-get-domain s:session) " that the error log is stml-crash-" (current-process-id) ".log
") + (print " Please notify support at " (sdat-domain s:session) " that the error log is stml-crash-" (current-process-id) ".log
") ;; (print "
")
 	 ;; ;; (print "   EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
 	 ;; ;; (print-error-message exn)
 	 ;; ;; (print-call-chain)
 	 ;; (print "
") @@ -2403,23 +2471,23 @@ ;; (exit) )) ;; find out if we are in debugmode (define (s:debug-mode?) - (sdat-get-debugmode s:session)) + (sdat-debug-mode s:session)) (define (s:never-called-page? page) (session:never-called-page? s:session page)) (define (s:set-err . args) - (sdat-set-curr-err! s:session args)) + (sdat-curr-err-set! s:session args)) (define (s:current-page) - (sdat-get-page s:session)) + (sdat-page s:session)) (define (s:delete-session) - (session:delete-session s:session (sdat-get-session-key s: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)))) @@ -2462,10 +2530,8 @@ (define s:session-var-delete! s:session-var-del!) ;; utility to get all vars as hash table (define (s:session-get-sessionvars) - (sdat-get-sessionvars s:session)) - - + (sdat-sessionvars s:session)) )