Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -15,14 +15,16 @@ OFILES = $(MODULEFILES:%.scm=%.o) TARGFILES = $(notdir $(SOFILES)) MODULES = $(addprefix $(TARGDIR)/modules/,$(TARGFILES)) install : $(TARGDIR)/stmlrun $(LOGDIR) $(MODULES) + +all : $(SOFILES) stmlrun : stmlrun.scm formdat.scm misc-stml.scm session.scm stml.scm \ setup.scm html-filter.scm requirements.scm keystore.scm \ - sugar.scm + cookie.scm csc stmlrun.scm $(TARGDIR)/stmlrun : stmlrun cp stmlrun $(TARGDIR) @@ -38,25 +40,24 @@ # $(LOGDIR) : mkdir -p $(LOGDIR) chmod a+rwx $(LOGDIR) -test: kiatoa.db +test: kiatoa.db cookie.so echo '(exit)'| csi -q ./tests/test.scm # modules # %.so : %.scm csc -I modules/* -s $< -all : $(SOFILES) +# Cookie is a special case for now. Make a loadable so for test +# Complile it in by include (see dependencies above). +cookie.so : cookie.scm + csc -s cookie.scm + -dbi.so : dbi.scm - csc -i dbi.scm - -installdbi : dbi.so - cp dbi.so /usr/local/lib/chicken/3/ # # $(CFILES): build/%.c: ../scm/%.scm ../scm/macros.scm # chicken $< -output-file $@ # # Index: formdat.scm ================================================================== --- formdat.scm +++ formdat.scm @@ -147,11 +147,11 @@ (define formdat:bin-file-type-rex (regexp "Content-Type:\\s+([^\\s]+)")) (define formdat:delim-patt-rex (regexp "^\\-+[0-9]+\\-*$")) ;; returns a hash with entries for all forms - could well use a proplist? (define (formdat:load-all) - (let ((request-method (getenv "REQUEST_METHOD"))) + (let ((request-method (get-environment-variable "REQUEST_METHOD"))) (if (and request-method (string=? request-method "POST")) (formdat:load-all-port (current-input-port))))) ;; (s:process-cgi-input (caaar dat)) Index: misc-stml.scm ================================================================== --- misc-stml.scm +++ misc-stml.scm @@ -149,12 +149,12 @@ (s:body (s:h1 "ERROR") (s:p err))))))) (define (s:validate-uri) - (let ((uri (getenv "REQUEST_URI")) - (qrs (getenv "QUERY_STRING"))) + (let ((uri (get-environment-variable "REQUEST_URI")) + (qrs (get-environment-variable "QUERY_STRING"))) (if (not uri) (set! uri qrs)) (if uri (string-match (regexp "^(/[a-z\\-\\._:0-9]*)*(|\\?([A-Za-z0-9_\\-\\+]+=[A-Za-z0-9_\\-\\.\\+]*&{0,1})*)$") uri) @@ -167,11 +167,11 @@ (s:log res) (loop (read-line p)(cons (list l "
") res))))) #t)))) (define (s:validate-inputs) - (if (not (s:validate-uri))(begin (s:error-page "Bad URI" (let ((ref (getenv "HTTP_REFERER"))) + (if (not (s:validate-uri))(begin (s:error-page "Bad URI" (let ((ref (get-environment-variable "HTTP_REFERER"))) (if ref (list "referred from" ref) ""))) (exit)))) Index: session.scm ================================================================== --- session.scm +++ session.scm @@ -160,12 +160,12 @@ (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) + ;; (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)))) @@ -191,11 +191,11 @@ (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 (getenv "REQUEST_METHOD")) + (sdat-set-request-method! self (get-environment-variable "REQUEST_METHOD")) (sdat-set-formdat! self (formdat:load-all)))) ;; setup the db with session tables, works for sqlite only right now (define (session:setup-db self) (let ((conn (sdat-get-conn self))) @@ -248,12 +248,12 @@ result) #f)) ;; (define (session:process-url-path self) - (let ((path-info (getenv "PATH_INFO")) - (query-string (getenv "QUERY_STRING"))) + (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) @@ -274,11 +274,11 @@ conn (string-append "INSERT INTO sessions (session_key) VALUES ('" tmpkey "')")) tmpkey)) ;; returns session key IFF it is in the HTTP_COOKIE (define (session:extract-session-key self) - (let ((http-session (getenv "HTTP_COOKIE"))) + (let ((http-session (get-environment-variable "HTTP_COOKIE"))) (if http-session (session:extract-key-from-param self (list http-session) "session_key") #f))) (define (session:get-session-id self session-key) @@ -470,18 +470,22 @@ (upd-query "UPDATE session_vars set value=? WHERE key=? AND session_id=? AND page=?;") (changed-count 0)) ;; save the delta only (for-each (lambda (page) ;; page is: "*globalvars*" "*sessionvars*" or otherstring - (let* ((master-slot-name (cond - ((string=? page "*sessionvars*") 'sessionvars) - ((string=? page "*globalvars*") 'globalvars) - (else 'pagevars))) - (before-slot-name (string->symbol (string-append (symbol->string master-slot-name) - "-before"))) - (master-ht (sdat-get-aster-slot-name self)) - (before-ht (sdat-get-efore-slot-name self)) + (let* ((before-after-ht (cond + ((string=? page "*sessionvars*") + (vector (sdat-get-sessionvars self) + (sdat-get-sessionvars-before self))) + ((string=? page "*globalvars*") + (vector (sdat-get-globalvars self) + (sdat-get-globalvars-before self))) + (else + (vector (sdat-get-pagevars self) + (sdat-get-pagevars-before self))))) + (master-ht (vector-ref before-after-ht 0)) + (before-ht (vector-ref before-after-ht 1)) (master-keys (hash-table-keys master-ht)) (before-keys (hash-table-keys before-ht)) (all-keys (delete-duplicates (append master-keys before-keys)))) (for-each (lambda (key) @@ -510,43 +514,10 @@ (s:sqlparam ins-query session-id page key master-value))) (else (err:log "Shouldn't get here"))))) all-keys))) ;; process all keys (list "*sessionvars*" "*globalvars*" page-name)))))) -;; ;; (print del-query) -;; (for-each -;; (lambda (page) -;; (pg:query-for-each (lambda (tuple) -;; (set! status #t)) -;; (s:sqlparam del-query session-id page-name) -;; conn)) -;; (list page-name "*sessionvars")) -;; ;; NOTE: The following approach is inefficient and a little dangerous. Need to keep -;; ;; two hashes, before and after and use the delta to drive updating the db OR -;; ;; even better move to using rpc with a central process for maintaining state -;; ;; write the session page specific vars to the db -;; (for-each (lambda (key) -;; (pg:query-for-each (lambda (tuple) -;; (set! status #t)) -;; (s:sqlparam ins-query session-id page-name -;; (s:any->string key) ;; just in case it is a symbol -;; (hash-table-ref pagevars key)) -;; conn)) -;; (hash-table-keys pagevars)) -;; ;; write the session specific vars to the db -;; ;; BUG!!! THIS IS LAZY AND WILL BREAK FOR SOMEONE ACCESSING THE SAME SESSION FROM TWO WINDOWS!!! -;; (for-each (lambda (key) -;; (pg:query-for-each (lambda (tuple) -;; (set! status #t)) -;; (s:sqlparam ins-query session-id "*sessionvars*" -;; (s:any->string key) ;; just in case it is a symbol -;; (hash-table-ref sessionvars key)) -;; conn)) -;; (hash-table-keys sessionvars)) -;; ;; global vars will require a little more care - delaying for now. -;; )))) - ;; (pg:sql-null-object? element) (define (session:read-config self) (let ((name (string-append "." (pathname-file (car (argv))) ".config"))) (if (not (file-exists? name)) (print name " not found at " (current-directory)) @@ -675,17 +646,17 @@ (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* ((server (if (getenv "HTTP_HOST") - (getenv "HTTP_HOST") - (getenv "SERVER_NAME"))) - (script (let ((script-name (string-split (getenv "SCRIPT_NAME") "/"))) + (let* ((server (if (get-environment-variable "HTTP_HOST") + (get-environment-variable "HTTP_HOST") + (get-environment-variable "SERVER_NAME"))) + (script (let ((script-name (string-split (get-environment-variable "SCRIPT_NAME") "/"))) (if (> (length script-name) 1) (string-append (car script-name) "/" (cadr script-name)) - (getenv "SCRIPT_NAME")))) ;; build script name from first two elements. This is a hangover from before I used ? in the URL. + (get-environment-variable "SCRIPT_NAME")))) ;; build script name from first two elements. This is a hangover from before I used ? in the URL. (session-key (sdat-get-session-key self)) (paramstr (session:param->string params))) ;; (session:log self "server=" server " script=" script " page=" page) (string-append "http://" server "/" script "/" page "?" paramstr))) ;; "/sn=" session-key))) Index: setup.scm ================================================================== --- setup.scm +++ setup.scm @@ -40,11 +40,11 @@ (define (s:current-page) (sdat-get-page s:session)) (define (s:delete-session) - (session:delete-session s:session (sdat-get-sesson-key s:session))) + (session:delete-session s:session (sdat-get-session-key s:session))) (define (s:call page . partsl) (if (null? partsl) (session:call s:session page) (session:call s:session page (car partsl)))) Index: stmlrun.scm ================================================================== --- stmlrun.scm +++ stmlrun.scm @@ -12,11 +12,10 @@ ;; (require-extension syntax-case) ;; (declare (run-time-macros)) (require-library dbi) -(define getenv get-environment-variable) (include "requirements.scm") (include "cookie.scm") (include "html-filter.scm") (include "misc-stml.scm") (include "formdat.scm") @@ -26,14 +25,14 @@ (include "setup.scm") ;; s:session gets created here (include "sqltbl.scm") (include "keystore.scm") ;; (include "sugar.scm") -(slot-set! s:session 'log-port ;; (current-error-port)) - (open-output-file (slot-ref s:session 'logfile) #:append)) +(sdat-set-log-port! s:session ;; (current-error-port)) + (open-output-file (sdat-get-logfile s:session) #:append)) -;; (s:log "HTTP_COOKIE" (getenv "HTTP_COOKIE")) +;; (s:log "HTTP_COOKIE" (get-environment-variable "HTTP_COOKIE")) ;; (s:log "stdin-dat=" (slot-ref s:session 'stdin-dat)) (s:validate-inputs) (session:run-actions s:session) Index: tests/test.scm ================================================================== --- tests/test.scm +++ tests/test.scm @@ -15,10 +15,11 @@ (import (prefix sqlite3 sqlite3:)) (require-library dbi) (load "./requirements.scm") +(load "./cookie.so") (load "./misc-stml.scm") (load "./formdat.scm") (load "./stml.scm") (load "./session.scm") ;(load "./sqltbl.scm") @@ -80,11 +81,11 @@ ;; test person (load "./tests/models/test.scm") -(print "Session key is " (slot-ref s:session 'session-key)) +(print "Session key is " (sdat-get-session-key s:session)) (test "Delete session" #t (s:delete-session)) (let ((fh (open-input-pipe "ls ./tests/pages/*/control.scm"))) (let loop ((l (read-line fh)))