Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -7,24 +7,26 @@ # implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR # PURPOSE. include install.cfg +SRCFILES = stml.scm misc-stml.scm session.scm sqltbl.scm formdat.scm setup.scm stmlrun.scm keystore.scm html-filter.scm cookie.scm MODULEFILES = $(wildcard modules/*/*-mod.scm) SOFILES = $(MODULEFILES:%.scm=%.so) CFILES = $(MODULEFILES:%.scm=%.c) -OFILES = $(MODULEFILES:%.scm=%.o) +OFILES = $(SRCFILES:%.scm=%.o) TARGFILES = $(notdir $(SOFILES)) MODULES = $(addprefix $(TARGDIR)/modules/,$(TARGFILES)) install : $(TARGDIR)/stmlrun $(LOGDIR) $(MODULES) -stmlrun : stmlrun.scm formdat.scm misc-stml.scm session.scm stml.scm \ - setup.scm html-filter.scm requirements.scm keystore.scm \ - sugar.scm - csc stmlrun.scm +all : $(SOFILES) +# stmlrun : stmlrun.scm formdat.scm misc-stml.scm session.scm stml.scm \ +# setup.scm html-filter.scm requirements.scm keystore.scm \ +# cookie.scm sqltbl.scm +# csc stmlrun.scm $(TARGDIR)/stmlrun : stmlrun cp stmlrun $(TARGDIR) chmod a+rx $(TARGDIR)/stmlrun @@ -31,33 +33,37 @@ $(TARGDIR)/modules : mkdir -p $(TARGDIR)/modules $(MODULES) : $(SOFILES) $(TARGDIR)/modules cp $< $@ + +stmlrun : $(OFILES) stmlrun.scm requirements.scm + csc $(OFILES) -o stmlrun # logging currently relies on this # $(LOGDIR) : mkdir -p $(LOGDIR) chmod a+rwx $(LOGDIR) -test: kiatoa.db +test: kiatoa.db cookie.so echo '(exit)'| csi -q ./tests/test.scm # modules # %.so : %.scm csc -I modules/* -s $< -all : $(SOFILES) - -dbi.so : dbi.scm - csc -i dbi.scm - -installdbi : dbi.so - cp dbi.so /usr/local/lib/chicken/3/ -# +%.o : %.scm + csc -c $< + +# Cookie is a special case for now. Make a loadable so for test +# Complile it in by include (see dependencies above). +cookie.so : cookie.scm + csc -s cookie.scm + + # $(CFILES): build/%.c: ../scm/%.scm ../scm/macros.scm # chicken $< -output-file $@ # # # $(OFILES): src/%.o: src/%.c ADDED cookie.scm Index: cookie.scm ================================================================== --- /dev/null +++ cookie.scm @@ -0,0 +1,252 @@ +;;; +;;; cookie.scm - parse and construct http state information +;;; +;;; Copyright (c) 2000-2003 Shiro Kawai, All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; +;;; 2. Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; +;;; 3. Neither the name of the authors nor the names of its contributors +;;; may be used to endorse or promote products derived from this +;;; software without specific prior written permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED +;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;; +;;; Ported to Chicken by Reed Sheridan +;;; + +;; Parser and constructor of http "Cookies" defined in +;; RFC 2965 HTTP state managemnet mechanism +;; +;; See also +;; RFC 2964 Use of HTTP state management +;; +;; The parser also supports the old Netscape spec +;; + +(declare (unit cookie)) +(require-extension srfi-1 srfi-13 srfi-14 regex) +(declare (export parse-cookie-string construct-cookie-string)) + +#> +#include +<# + +(define fmt-time + (foreign-lambda* c-string ((long secs_since_epoch)) + "static char buf[256];" + "time_t t = (time_t) secs_since_epoch;" + "strftime(buf, sizeof(buf), \"%a, %d-%b-%Y %H:%M:%S GMT\", gmtime(&t));" + "return(buf);")) + +;; utility fn. breaks ``attr=value;attr=value ... '' into alist. +;; version is a cookie version. if version>0, we allow comma as the +;; delimiter as well as semicolon. +(define (parse-av-pairs input version) + (define attr-regexp + (if (= version 0) + (regexp "\\s*([\\w$_-]+)\\s*([=\\;]\\s*)?") + (regexp "\\s*([\\w$_-]+)\\s*([=\\;,]\\s*)?"))) + (define attr-delim + (if (= version 0) #\; (char-set #\, #\\ #\;))) + + (define (read-attr input r) + (cond ((string-null? input) (reverse! r)) + ((string-search attr-regexp input) + => (lambda (m) + (if (and-let* ((delimiter (third m))) ;;is an attr_value pai + (string-prefix? "=" delimiter)) + (let ((attr (second m)) + (rest (string-search-after attr-regexp input))) + (if (string-prefix? "\"" rest) + (read-token-quoted attr (string-drop rest 1) r) + (read-token attr rest r))) + (read-attr (string-search-after attr-regexp input) ;; Skip ahead if broken input? + (alist-cons (second m) #f r))))) + (else + ;; the input is broken; for now, we ignore the rest. + (reverse! r)))) + (define (read-token attr input r) + (cond ((string-index input attr-delim) + => (lambda (i) + (read-attr (string-drop input (+ i 1)) + (alist-cons attr + (string-trim-right (string-take input i)) + r)))) + (else + (reverse! (alist-cons attr (string-trim-right input) r))))) + (define (read-token-quoted attr input r) + (let loop ((input input) + (partial '())) + (cond ((string-index input (char-set #\\ #\")) + => (lambda (i) + (let ((c (string-ref input i))) + (if (char=? c #\\) + (if (< (string-length input) (+ i 1)) + (error-unterminated attr) + (loop (string-drop input (+ i 2)) + (cons* (string (string-ref input (+ i 1))) + (string-take input i) + partial))) + (read-attr (string-drop input (+ i 1)) + (alist-cons attr + (string-concatenate-reverse + (cons (string-take input i) + partial)) + r)))))) + (else (error-unterminated attr))))) + (define (error-unterminated attr) + (error "Unterminated quoted value given for attribute" attr)) + + (read-attr input '())) + +;; Parses the header value of "Cookie" request header. +;; If cookie version is known by "Cookie2" request header, it should +;; be passed to version (as integer). Otherwise, it figures out +;; the cookie version from input. +;; +;; Returns the following format. +;; (( [:path ] [:domain ] [:port ]) +;; ...) + +(define (parse-cookie-string input #!optional version) + (let ((ver (cond ((integer? version) version) + ((string-search "^\\s*\\$Version\\s*=\\s*(\\d+)" input) + => (lambda (m) + (string->number (cadr m)))) + (else 0)))) + (let loop ((av-pairs (parse-av-pairs input ver)) + (r '()) + (current '())) + (cond ((null? av-pairs) + (if (null? current) + (reverse r) + (reverse (cons (reverse current) r)))) + ((string-ci=? "$path" (caar av-pairs)) + (loop (cdr av-pairs) r (cons* (cdar av-pairs) path: current))) + ((string-ci=? "$domain" (caar av-pairs)) + (loop (cdr av-pairs) r (cons* (cdar av-pairs) domain: current))) + ((string-ci=? "$port" (caar av-pairs)) + (loop (cdr av-pairs) r (cons* (cdar av-pairs) port: current))) + (else + (if (null? current) + (loop (cdr av-pairs) r (list (cdar av-pairs) (caar av-pairs))) + (loop (cdr av-pairs) + (cons (reverse current) r) + (list (cdar av-pairs) (caar av-pairs))))))))) + +;; Construct a cookie string suitable for Set-Cookie or Set-Cookie2 header. +;; specs is the following format. +;; +;; (( [:comment ] [:comment-url ] +;; [:discard ] [:domain ] +;; [:max-age ] [:path ] [:port ] +;; [:secure ] [:version ] [:expires ] +;; ) ...) +;; +;; Returns a list of cookie strings for each = pair. In the +;; ``new cookie'' implementation, you can join them by comma and send it +;; at once with Set-cookie2 header. For the old netscape protocol, you +;; must send each of them by Set-cookie header. + + +(define (construct-cookie-string specs #!optional (version 1)) + (map (lambda (spec) (construct-cookie-string-1 spec version)) + specs)) + +(define (construct-cookie-string-1 spec ver) + (when (< (length spec) 2) + (error "bad cookie spec: at least and required" spec)) + (let ((name (car spec)) + (value (cadr spec))) + (let loop ((attr (cddr spec)) + (r (list (if value + (string-append name "=" + (quote-if-needed value)) + name)))) + (define (next s) (loop (cddr attr) (cons s r))) + (define (ignore) (loop (cddr attr) r)) + (cond + ((null? attr) (string-join (reverse r) ";")) + ((null? (cdr attr)) + (error (conc "bad cookie spec: attribute " (car attr) " requires value" ))) + ((eqv? comment: (car attr)) + (if (> ver 0) + (next (string-append "Comment=" (quote-if-needed (cadr attr)))) + (ignore))) + ((eqv? comment-url: (car attr)) + (if (> ver 0) + (next (string-append "CommentURL=" (quote-value (cadr attr)))) + (ignore))) + ((eqv? discard: (car attr)) + (if (and (> ver 0) (cadr attr)) (next "Discard") (ignore))) + ((eqv? domain: (car attr)) + (next (string-append "Domain=" (cadr attr)))) + ((eqv? max-age: (car attr)) + (if (> ver 0) + (next (sprintf "Max-Age=~a" (cadr attr))) + (ignore))) + ((eqv? path: (car attr)) + (next (string-append "Path=" (quote-if-needed (cadr attr))))) + ((eqv? port: (car attr)) + (if (> ver 0) + (next (string-append "Port=" (quote-value (cadr attr)))) + (ignore))) + ((eqv? secure: (car attr)) + (if (cadr attr) (next "Secure") (ignore))) + ((eqv? version: (car attr)) + (if (> ver 0) + (next (sprintf "Version=~a" (cadr attr))) + (ignore))) + ((eqv? expires: (car attr)) + (if (> ver 0) + (ignore) + (next (make-expires-attr (cadr attr))))) + (else (error "Unknown cookie attribute" (car attr)))) + )) + ) + + +;; (define (quote-value value) +;; (string-append "\"" (regexp-replace-all #/\"|\\/ value "\\\\\\0") "\"")) + +(define (quote-value value) + (string-append "\"" (string-substitute* value '(("\\\"" . "\\\"") ("\\\\" . "\\\\"))) "\"")) + +(define quote-if-needed + (let ((rx (regexp "[\\\",;\\\\ \\t\\n]"))) + (lambda (value) + (if (string-search rx value) + (quote-value value) + value)))) + +(define (make-expires-attr time) + (sprintf "Expires=~a" + (if (number? time) + (fmt-time time) + time))) + +;;;; Added support functions from my utils, split this out + +(define (string-search-after r s #!optional (start 0)) + (and-let* ((match-indices (string-search-positions r s start)) + (right-match (second (first match-indices)))) + (substring s right-match))) Index: formdat.scm ================================================================== --- formdat.scm +++ formdat.scm @@ -1,15 +1,16 @@ -;; Copyright 2007-2008, Matthew Welland. +;; Copyright 2007-2011, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. -(include "requirements.scm") +(declare (unit formdat)) +(use regex) (define formdat:*debug* #f) ;; Old data format was something like this. BUT! ;; Forms do not have names so the hierarcy is @@ -20,53 +21,54 @@ ;; | 'form-data=hashtable ;; | | name => value ;; ;; New data format is only the portion from above -(define-class () - (form-data - )) - -(define-method (initialize (self ) initargs) - (call-next-method) - (slot-set! self 'form-data (make-hash-table)) - (initialize-slots self initargs)) - -(define-method (formdat:get (self ) key) - (hash-table-ref/default (slot-ref self 'form-data) key #f)) +;; (define-class () +;; (form-data +;; )) +(define (make-formdat:formdat)(make-vector (hash-table))) +(define-inline (formdat:formdat-get-data vec) (vector-ref vec 0)) +(define-inline (formdat:formdat-set-data! vec val)(vector-set! vec 0 val)) + +(define (formdat:initialize self) + (formdat:formdat-set-data! self (make-hash-table))) + +(define (formdat:get self key) + (hash-table-ref/default (formdat:formdat-get-data self) key #f)) ;; change to convert data to list and append val if already exists ;; or is a list -(define-method (formdat:set! (self ) key val) +(define (formdat:set! self key val) (let ((prev-val (formdat:get self key)) - (ht (slot-ref self 'form-data))) + (ht (formdat:formdat-get-data self))) (if prev-val (if (list? prev-val) (hash-table-set! ht key (cons val prev-val)) (hash-table-set! ht key (list val prev-val))) (hash-table-set! ht key val)) self)) -(define-method (formdat:keys (self )) - (hash-table-keys (slot-ref self 'form-data))) +(define (formdat:keys self) + (hash-table-keys (formdat:formdat-get-data self))) -(define-method (formdat:printall (self ) printproc) +(define (formdat:printall self printproc) (printproc "formdat:printall " (formdat:keys self)) (for-each (lambda (k) (printproc k " => " (formdat:get self k))) (formdat:keys self))) -(define-method (formdat:all->strings (self )) +(define (formdat:all->strings self) (let ((res '())) (for-each (lambda (k) (set! res (cons (conc k "=>" (formdat:get self k)) res))) (formdat:keys self)) res)) ;; call with *one* of the lists in the list of lists created by CGI:url-unquote -(define-method (formdat:load (self ) formlist) - (let ((ht (slot-ref self 'form-data))) +(define (formdat:load self formlist) + (let ((ht (formdat:formdat-get-data self))) (if (null? formlist) self ;; no values provided, return self for no good reason (let loop ((head (car formlist)) (tail (cdr formlist))) (let ((key (car head)) (val (cdr head))) @@ -146,18 +148,18 @@ (define formdat:bin-file-type-rex (regexp "Content-Type:\\s+([^\\s]+)")) (define formdat:delim-patt-rex (regexp "^\\-+[0-9]+\\-*$")) ;; returns a hash with entries for all forms - could well use a proplist? (define (formdat:load-all) - (let ((request-method (getenv "REQUEST_METHOD"))) + (let ((request-method (get-environment-variable "REQUEST_METHOD"))) (if (and request-method (string=? request-method "POST")) (formdat:load-all-port (current-input-port))))) ;; (s:process-cgi-input (caaar dat)) (define (formdat:load-all-port inp) - (let* ((formdat (make ))) + (let* ((formdat (make-formdat:formdat))) ;; (debugp (open-output-file (conc (slot-ref s:session 'sroot) "/delme-" (current-user-id) ".log")))) ;; (write-string (read-string #f inp) #f debugp) (let ((alldats (formdat:dat->list inp 10e6))) ;; (format debugp "formdat : alldats: ~A\n" alldats) Index: html-filter.scm ================================================================== --- html-filter.scm +++ html-filter.scm @@ -1,13 +1,15 @@ -;; Copyright 2007-2008, Matthew Welland. +;; Copyright 2007-2011, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. + +(declare (unit html-filter)) ;; (define (s:split-string strng delim) (if (eq? (string-length strng) 0) (list strng) (let loop ((head (make-string 1 (car (string->list strng)))) Index: keystore.scm ================================================================== --- keystore.scm +++ keystore.scm @@ -1,6 +1,6 @@ -;; Copyright 2007-2008, Matthew Welland. +;; Copyright 2007-2011, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the @@ -9,10 +9,12 @@ ;;====================================================================== ;; The meta data key store, just a general dumping ground for values ;; only used occasionally ;;====================================================================== + +(declare (unit keystore)) (define (keystore:get db key) (dbi:get-one db "SELECT value FROM metadata WHERE key=?;" key)) (define (keystore:set! db key value) Index: misc-stml.scm ================================================================== --- misc-stml.scm +++ misc-stml.scm @@ -1,6 +1,6 @@ -;; Copyright 2007-2008, Matthew Welland. +;; Copyright 2007-2011, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the @@ -8,10 +8,13 @@ ;; PURPOSE. ;;====================================================================== ;; dumbobj helpers ;;====================================================================== + +(declare (unit misc-stml)) +(use regex) ;; given a list of symbols give the count of the matching symbol ;; l => '(a b c) (dumobj:indx a 'b) => 1 (define (s:get-fieldnum lst field-name) (let loop ((head (car lst)) @@ -149,12 +152,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 +170,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 @@ -1,15 +1,18 @@ -;; Copyright 2007-2008, Matthew Welland. +;; Copyright 2007-2011, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. -(include "requirements.scm") +(declare (unit session)) +(require-library dbi) +(use regex) +(declare (uses cookie)) ;; sessions table ;; id session_id session_key ;; create table sessions (id serial not null,session-key text); @@ -20,145 +23,232 @@ ;; TODO ;; Concept of order num incremented with each page access ;; if a branch is taken then a new session would need to be created ;; -(define-class () - (dbtype ;; 'pg or 'sqlite3 - dbinit - conn - params ;; params from the key=val&key1=val2 string - path-params ;; remaining params from the path - session-key - session-id - domain - toppage ;; defaults to "index" - override in .stml.config if desired - page ;; the page name - defaults to home - curr-page ;; the current page being evaluated - content-type ;; the default content type is text/html, override to deliver other stuff - page-type ;; use in conjunction with content-type to deliver other payloads - sroot - twikidir ;; location for twikis - needs to be fully writable by web server - pagedat - alt-page-dat - pagevars ;; session vars specific to this page - pagevars-before - sessionvars ;; session vars visible to all pages - sessionvars-before - globalvars ;; global vars visible to all sessions - globalvars-before - logpt - formdat - request-method - session-cookie - curr-err - log-port - logfile - seen-pages - page-dir-style ;; #t = new style, #f = old style - debugmode)) +;; 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 33)) +(define (sdat-get-dbtype vec) (vector-ref vec 0)) +(define (sdat-get-dbinit vec) (vector-ref vec 1)) +(define (sdat-get-conn vec) (vector-ref vec 2)) +(define (sdat-get-params vec) (vector-ref vec 3)) +(define (sdat-get-path-params vec) (vector-ref vec 4)) +(define (sdat-get-session-key vec) (vector-ref vec 5)) +(define (sdat-get-session-id vec) (vector-ref vec 6)) +(define (sdat-get-domain vec) (vector-ref vec 7)) +(define (sdat-get-toppage vec) (vector-ref vec 8)) +(define (sdat-get-page vec) (vector-ref vec 9)) +(define (sdat-get-curr-page vec) (vector-ref vec 10)) +(define (sdat-get-content-type vec) (vector-ref vec 11)) +(define (sdat-get-page-type vec) (vector-ref vec 12)) +(define (sdat-get-sroot vec) (vector-ref vec 13)) +(define (sdat-get-twikidir vec) (vector-ref vec 14)) +(define (sdat-get-pagedat vec) (vector-ref vec 15)) +(define (sdat-get-alt-page-dat vec) (vector-ref vec 16)) +(define (sdat-get-pagevars vec) (vector-ref vec 17)) +(define (sdat-get-pagevars-before vec) (vector-ref vec 18)) +(define (sdat-get-sessionvars vec) (vector-ref vec 19)) +(define (sdat-get-sessionvars-before vec) (vector-ref vec 20)) +(define (sdat-get-globalvars vec) (vector-ref vec 21)) +(define (sdat-get-globalvars-before vec) (vector-ref vec 22)) +(define (sdat-get-logpt vec) (vector-ref vec 23)) +(define (sdat-get-formdat vec) (vector-ref vec 24)) +(define (sdat-get-request-method vec) (vector-ref vec 25)) +(define (sdat-get-session-cookie vec) (vector-ref vec 26)) +(define (sdat-get-curr-err vec) (vector-ref vec 27)) +(define (sdat-get-log-port vec) (vector-ref vec 28)) +(define (sdat-get-logfile vec) (vector-ref vec 29)) +(define (sdat-get-seen-pages vec) (vector-ref vec 30)) +(define (sdat-get-page-dir-style vec) (vector-ref vec 31)) +(define (sdat-get-debugmode vec) (vector-ref vec 32)) +(define (sdat-set-dbtype! vec val)(vector-set! vec 0 val)) +(define (sdat-set-dbinit! vec val)(vector-set! vec 1 val)) +(define (sdat-set-conn! vec val)(vector-set! vec 2 val)) +(define (sdat-set-params! vec val)(vector-set! vec 3 val)) +(define (sdat-set-path-params! vec val)(vector-set! vec 4 val)) +(define (sdat-set-session-key! vec val)(vector-set! vec 5 val)) +(define (sdat-set-session-id! vec val)(vector-set! vec 6 val)) +(define (sdat-set-domain! vec val)(vector-set! vec 7 val)) +(define (sdat-set-toppage! vec val)(vector-set! vec 8 val)) +(define (sdat-set-page! vec val)(vector-set! vec 9 val)) +(define (sdat-set-curr-page! vec val)(vector-set! vec 10 val)) +(define (sdat-set-content-type! vec val)(vector-set! vec 11 val)) +(define (sdat-set-page-type! vec val)(vector-set! vec 12 val)) +(define (sdat-set-sroot! vec val)(vector-set! vec 13 val)) +(define (sdat-set-twikidir! vec val)(vector-set! vec 14 val)) +(define (sdat-set-pagedat! vec val)(vector-set! vec 15 val)) +(define (sdat-set-alt-page-dat! vec val)(vector-set! vec 16 val)) +(define (sdat-set-pagevars! vec val)(vector-set! vec 17 val)) +(define (sdat-set-pagevars-before! vec val)(vector-set! vec 18 val)) +(define (sdat-set-sessionvars! vec val)(vector-set! vec 19 val)) +(define (sdat-set-sessionvars-before! vec val)(vector-set! vec 20 val)) +(define (sdat-set-globalvars! vec val)(vector-set! vec 21 val)) +(define (sdat-set-globalvars-before! vec val)(vector-set! vec 22 val)) +(define (sdat-set-logpt! vec val)(vector-set! vec 23 val)) +(define (sdat-set-formdat! vec val)(vector-set! vec 24 val)) +(define (sdat-set-request-method! vec val)(vector-set! vec 25 val)) +(define (sdat-set-session-cookie! vec val)(vector-set! vec 26 val)) +(define (sdat-set-curr-err! vec val)(vector-set! vec 27 val)) +(define (sdat-set-log-port! vec val)(vector-set! vec 28 val)) +(define (sdat-set-logfile! vec val)(vector-set! vec 29 val)) +(define (sdat-set-seen-pages! vec val)(vector-set! vec 30 val)) +(define (sdat-set-page-dir-style! vec val)(vector-set! vec 31 val)) +(define (sdat-set-debugmode! vec val)(vector-set! vec 32 val)) + +;; (define-class () +;; (dbtype ;; 'pg or 'sqlite3 +;; dbinit +;; conn +;; params ;; params from the key=val&key1=val2 string +;; path-params ;; remaining params from the path +;; session-key +;; session-id +;; domain +;; toppage ;; defaults to "index" - override in .stml.config if desired +;; page ;; the page name - defaults to home +;; curr-page ;; the current page being evaluated +;; content-type ;; the default content type is text/html, override to deliver other stuff +;; page-type ;; use in conjunction with content-type to deliver other payloads +;; sroot +;; twikidir ;; location for twikis - needs to be fully writable by web server +;; pagedat +;; alt-page-dat +;; pagevars ;; session vars specific to this page +;; pagevars-before +;; sessionvars ;; session vars visible to all pages +;; sessionvars-before +;; globalvars ;; global vars visible to all sessions +;; globalvars-before +;; logpt +;; formdat +;; request-method +;; session-cookie +;; curr-err +;; log-port +;; logfile +;; seen-pages +;; page-dir-style ;; #t = new style, #f = old style +;; debugmode)) ;; SPLIT INTO STRAIGHT FORWARD INIT AND COMPLEX INIT -(define-method (initialize (self ) initargs) - (call-next-method) - (slot-set! self 'dbtype 'pg) - (slot-set! self 'page "home") ;; these are defaults - (slot-set! self 'curr-page "home") - (slot-set! self 'content-type "Content-type: text/html; charset=iso-8859-1\n\n") - (slot-set! self 'page-type 'html) - (slot-set! self 'toppage "index") - (slot-set! self 'params '()) ;; - (slot-set! self 'path-params '()) - (slot-set! self 'session-key #f) - (slot-set! self 'pagedat '()) - (slot-set! self 'alt-page-dat #f) - (slot-set! self 'sroot "./") - (slot-set! self 'session-cookie #f) - (slot-set! self 'curr-err #f) - (slot-set! self 'log-port (current-error-port)) - (slot-set! self 'seen-pages '()) - (slot-set! self 'page-dir-style #t) ;; #t : pages/_(view|cntl).scm +(define (session:initialize self) + (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 - (slot-set! self 'debugmode #f) - (for-each (lambda (slot-name) - (slot-set! self slot-name (make-hash-table))) - (list 'pagevars 'sessionvars 'globalvars 'pagevars-before - 'sessionvars-before 'globalvars-before)) - (slot-set! self 'domain "locahost") ;; end of defaults - (initialize-slots self (session:read-config self)) - ;; some values read in from the config file need to be evaled - (for-each (lambda (slot-name) - (slot-set! self slot-name (eval (slot-ref self slot-name)))) - (list 'dbtype)) - (initialize-slots self initargs)) - -(define-method (session:setup (self )) - (let ((dbtype (slot-ref self 'dbtype)) - (dbinit (eval (slot-ref self 'dbinit))) + (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)) + (page-dir (s:find-param 'page-dir-style configdat))) + (if sroot (sdat-set-sroot! self sroot)) + (if logfile (sdat-set-logfile! self logfile)) + (if dbtype (sdat-set-dbtype! self dbtype)) + (if dbinit (sdat-set-dbinit! self dbinit)) + (if domain (sdat-set-domain! self domain)) + (sdat-set-page-dir-style! self page-dir) + ;; (print "configdat: ")(pp configdat) + ;;(session:log self "sroot: " sroot " logfile: " logfile " dbtype: " dbtype + ;; " dbinit: " dbinit " domain: " domain " page-dir-style: " page-dir) + ) + ) +;; (let ((dbtype (sdat-get-dbtype self))) +;; (print "dbtype: " dbtype) +;; (sdat-set-dbtype! self (eval dbtype)))) + +(define (session:setup self) + (let ((dbtype (sdat-get-dbtype self)) + (dbinit (eval (sdat-get-dbinit self))) (dbexists #f)) (let ((dbfname (alist-ref 'dbname dbinit))) (if (eq? dbtype 'sqlite3) (if (file-exists? dbfname) (begin ;; (session:log self "setting dbexists to #t") (set! dbexists #t)))) ;; (session:log self "dbtype: " dbtype " dbfname: " dbfname " dbexists: " dbexists)) ) - (slot-set! self 'conn (dbi:open dbtype dbinit)) + (sdat-set-conn! self (dbi:open dbtype dbinit)) (if (and (not dbexists)(eq? dbtype 'sqlite3)) (begin (print "WARNING: Setting up session db with sqlite3") (session:setup-db self))) (session:process-url-path self) (session:setup-session-key self) ;; capture stdin if this is a POST - (slot-set! self 'request-method (getenv "REQUEST_METHOD")) - (slot-set! self 'formdat (formdat:load-all)))) + (sdat-set-request-method! self (get-environment-variable "REQUEST_METHOD")) + (sdat-set-formdat! self (formdat:load-all)))) ;; setup the db with session tables, works for sqlite only right now -(define-method (session:setup-db (self )) - (let ((conn (slot-ref self 'conn))) +(define (session:setup-db self) + (let ((conn (sdat-get-conn self))) (for-each (lambda (stmt) (dbi:exec conn stmt)) (list "CREATE TABLE session_vars (id INTEGER PRIMARY KEY,session_id INTEGER,page TEXT,key TEXT,value TEXT);" "CREATE TABLE sessions (id INTEGER PRIMARY KEY,session_key TEXT,last_used TIMESTAMP);" "CREATE TABLE metadata (id INTEGER PRIMARY KEY,key TEXT,value TEXT);")))) ;; ;; if we have a session_key look up the session-id and store it -;; (slot-set! self 'session-id (session:get-id self))) +;; (sdat-set-session-id! self (session:get-id self))) ;; only set session-cookie when a new session is created -(define-method (session:setup-session-key (self )) +(define (session:setup-session-key self) (let* ((sk (session:extract-session-key self)) (sid (if sk (session:get-id self sk) #f))) (if (not sid) ;; need a new key (let* ((new-key (session:get-new-key self)) (new-sid (session:get-id self new-key))) - (slot-set! self 'session-key new-key) - (slot-set! self 'session-id new-sid) - (slot-set! self 'session-cookie (session:make-cookie self))) - (slot-set! self 'session-id sid)))) + (sdat-set-session-key! self new-key) + (sdat-set-session-id! self new-sid) + (sdat-set-session-cookie! self (session:make-cookie self))) + (sdat-set-session-id! self sid)))) -(define-method (session:make-cookie (self )) - ;; (list (conc "session_key=" (slot-ref self 'session-key) "; Path=/; Domain=." (slot-ref self 'domain) "; Max-Age=" (* 86400 14) "; Version=1"))) +(define (session:make-cookie self) + ;; (list (conc "session_key=" (sdat-get-session-key self) "; Path=/; Domain=." (sdat-get-domain self) "; Max-Age=" (* 86400 14) "; Version=1"))) (list (string-substitute ";" "; " (car (construct-cookie-string ;; warning! messing up this itty bitty bit of code will cost much time! - `(("session_key" ,(slot-ref self 'session-key) + `(("session_key" ,(sdat-get-session-key self) expires: ,(+ (current-seconds) (* 14 86400)) max-age: (* 14 86400) path: "/" ;; - domain: ,(string-append "." (slot-ref self 'domain)) + domain: ,(string-append "." (sdat-get-domain self)) version: 1)) 0))))) ;; look up a given session key and return the id if found, #f if not found -(define-method (session:get-id (self ) session-key) - ;; (let ((session-key (slot-ref self 'session-key))) +(define (session:get-id self session-key) + ;; (let ((session-key (sdat-get-session-key self))) (if session-key (let ((query (string-append "SELECT id FROM sessions WHERE session_key='" session-key "'")) - (conn (slot-ref self 'conn)) + (conn (sdat-get-conn self)) (result #f)) (dbi:for-each-row (lambda (tuple) (set! result (vector-ref tuple 0))) conn query) @@ -165,79 +255,79 @@ (if result (dbi:exec conn (conc "UPDATE sessions SET last_used=" (dbi:now conn) " WHERE session_key=?;") session-key)) result) #f)) ;; -(define-method (session:process-url-path (self )) - (let ((path-info (getenv "PATH_INFO")) - (query-string (getenv "QUERY_STRING"))) +(define (session:process-url-path self) + (let ((path-info (get-environment-variable "PATH_INFO")) + (query-string (get-environment-variable "QUERY_STRING"))) ;; (session:log self "path-info=" path-info " query-string=" query-string) (if path-info (let* ((parts (string-split path-info "/")) (numparts (length parts))) (if (> numparts 0) - (slot-set! self 'page (car parts))) + (sdat-set-page! self (car parts))) ;; (session:log self "url-path=" url-path " parts=" parts) (if (> numparts 1) - (slot-set! self 'path-params (cdr parts))) + (sdat-set-path-params! self (cdr parts))) (if query-string - (slot-set! self 'params (string-split query-string "&"))))))) + (sdat-set-params! self (string-split query-string "&"))))))) ;; BUGGY! -(define-method (session:get-new-key (self )) - (let ((conn (slot-ref self 'conn)) +(define (session:get-new-key self) + (let ((conn (sdat-get-conn self)) (tmpkey (session:make-rand-string 20)) (status #f)) (dbi:for-each-row (lambda (tuple) (set! status #t)) conn (string-append "INSERT INTO sessions (session_key) VALUES ('" tmpkey "')")) tmpkey)) ;; returns session key IFF it is in the HTTP_COOKIE -(define-method (session:extract-session-key (self )) - (let ((http-session (getenv "HTTP_COOKIE"))) +(define (session:extract-session-key self) + (let ((http-session (get-environment-variable "HTTP_COOKIE"))) (if http-session (session:extract-key-from-param self (list http-session) "session_key") #f))) -(define-method (session:get-session-id (self ) session-key) +(define (session:get-session-id self session-key) (let ((query "SELECT id FROM sessions WHERE session_key=?;") (result #f)) ;; (pg:query-for-each (lambda (tuple) ;; (set! result (vector-ref tuple 0))) ;; (vector-ref tuple 0))) ;; (s:sqlparam query session-key) - ;; (slot-ref self 'conn)) + ;; (sdat-get-conn self)) ;; conn) (dbi:for-each-row (lambda (tuple) (set! result (vector-ref tuple 0))) ;; (vector-ref tuple 0))) - (slot-ref self 'conn) + (sdat-get-conn self) (s:sqlparam query session-key)) result)) ;; delete all records for a session ;; -(define-method (session:delete-session (self ) session-key) +(define (session:delete-session self session-key) (let ((session-id (session:get-session-id self session-key)) (qry (conc "BEGIN;" "DELETE FROM session_vars WHERE session_id=?;" "DELETE FROM sessions WHERE id=?;" "COMMIT;")) - (conn (slot-ref self 'conn))) + (conn (sdat-get-conn self))) (if session-id (begin (dbi:exec conn qry session-id session-id) - (initialize self '()) + (session:initialize self) (session:setup self))) (not (session:get-session-id self session-key)))) -;; (define-method (session:delete-session (self ) session-key) +;; (define (session:delete-session self session-key) ;; (let ((session-id (session:get-session-id self session-key)) ;; (queries (list "BEGIN;" ;; "DELETE FROM session_vars WHERE session_id=?;" ;; "DELETE FROM sessions WHERE id=?;" ;; "COMMIT;")) -;; (conn (slot-ref self 'conn))) +;; (conn (sdat-get-conn self))) ;; (if session-id ;; (begin ;; (for-each ;; (lambda (query) ;; (dbi:exec conn query session-id)) @@ -244,45 +334,45 @@ ;; queries) ;; (initialize self '()) ;; (session:setup self))) ;; (not (session:get-session-id self session-key)))) -(define-method (session:extract-key (self ) key) - (let ((params (slot-ref self 'params))) +(define (session:extract-key self key) + (let ((params (sdat-get-params self))) (session:extract-key-from-param self params key))) -(define-method (session:extract-key-from-param (self ) params key) +(define (session:extract-key-from-param self params key) (let ((r1 (regexp (string-append "^" key "=([^=]+)$")))) (if (< (length params) 1) #f (let loop ((head (car params)) (tail (cdr params))) (let ((match (string-match r1 head))) (cond (match (let ((session-key (list-ref match 1))) - (slot-set! self 'session-key (list-ref match 1)) + (sdat-set-session-key! self (list-ref match 1)) session-key)) ((null? tail) #f) (else (loop (car tail) (cdr tail))))))))) -(define-method (session:set-page! (self ) page_name) - (slot-set! self 'page page_name)) - -(define-method (session:close (self )) - (dbi:close (slot-ref self 'conn))) -;; (close-output-port (slot-ref self 'logpt)) - -(define-method (session:err-msg (self ) msg) - (hash-table-set! (slot-ref self 'sessionvars) "ERROR_MSG" +(define (session:set-page! self page_name) + (sdat-set-page! self page_name)) + +(define (session:close self) + (dbi:close (sdat-get-conn self))) +;; (close-output-port (sdat-get-logpt self)) + +(define (session:err-msg self msg) + (hash-table-set! (sdat-get-sessionvars self) "ERROR_MSG" (string-intersperse (map s:any->string msg) " "))) -(define-method (session:prev-err (self )) - (let ((prev-err (hash-table-ref/default (slot-ref self 'sessionvars-before) "ERROR_MSG" #f)) - (curr-err (hash-table-ref/default (slot-ref self 'sessionvars) "ERROR_MSG" #f))) +(define (session:prev-err self) + (let ((prev-err (hash-table-ref/default (sdat-get-sessionvars-before self) "ERROR_MSG" #f)) + (curr-err (hash-table-ref/default (sdat-get-sessionvars self) "ERROR_MSG" #f))) (if prev-err prev-err (if curr-err curr-err #f)))) ;; session vars ;; 1. keys are always a string NOT a symbol @@ -289,66 +379,66 @@ ;; 2. values are always a string conversion is the responsibility of the ;; consuming function (at least for now, I'd like to change this) ;; set a session var for the current page ;; -(define-method (session:set! (self ) key value) - (hash-table-set! (slot-ref self 'pagevars) (s:any->string key) (s:any->string value))) +(define (session:set! self key value) + (hash-table-set! (sdat-get-pagevars self) (s:any->string key) (s:any->string value))) ;; del a var for the current page ;; -(define-method (session:del! (self ) key) - (hash-table-delete! (slot-ref self 'pagevars) (s:any->string key))) +(define (session:del! self key) + (hash-table-delete! (sdat-get-pagevars self) (s:any->string key))) ;; get the appropriate hash given a page "*sessionvars*, *globalvars* or page ;; -(define-method (session:get-page-hash (self ) page) +(define (session:get-page-hash self page) (if (string=? page "*sessionvars*") - (slot-ref self 'sessionvars) + (sdat-get-sessionvars self) (if (string=? page "*globalvars*") - (slot-ref self 'globalvars) - (slot-ref self 'pagevars)))) + (sdat-get-globalvars self) + (sdat-get-pagevars self)))) ;; set a session var for a given page ;; -(define-method (session:set! (self ) page key value) +(define (session:set! self page key value) (let ((ht (session:get-page-hash self page))) (hash-table-set! ht (s:any->string key) (s:any->string value)))) ;; get session vars for the current page ;; -(define-method (session:get (self ) key) - (hash-table-ref/default (slot-ref self 'pagevars) key #f)) +(define (session:get self key) + (hash-table-ref/default (sdat-get-pagevars self) key #f)) ;; get session vars for a specified page ;; -(define-method (session:get (self ) page key) +(define (session:get self page key) (let ((ht (session:get-page-hash self page))) (hash-table-ref/default ht key #f))) ;; delete a session var for a specified page ;; -(define-method (session:del! (self ) page key) +(define (session:del! self page key) (let ((ht (session:get-page-hash self page))) (hash-table-delete! ht key))) ;; get ALL keys for this page and store in the session pagevars hash ;; -(define-method (session:get-vars (self )) - (let ((session-id (slot-ref self 'session-id))) +(define (session:get-vars self) + (let ((session-id (sdat-get-session-id self))) (if (not session-id) (err:log "ERROR: No session id in session object! session:get-vars") (let* ((result #f) - (conn (slot-ref self 'conn)) - (pagevars-before (slot-ref self 'pagevars-before)) - (sessionvars-before (slot-ref self 'sessionvars-before)) - (globalvars-before (slot-ref self 'globalvars-before)) - (pagevars (slot-ref self 'pagevars)) - (sessionvars (slot-ref self 'sessionvars)) - (globalvars (slot-ref self 'globalvars)) - (page-name (slot-ref self 'page)) - (session-key (slot-ref self 'session-key)) + (conn (sdat-get-conn self)) + (pagevars-before (sdat-get-pagevars-before self)) + (sessionvars-before (sdat-get-sessionvars-before self)) + (globalvars-before (sdat-get-globalvars-before self)) + (pagevars (sdat-get-pagevars self)) + (sessionvars (sdat-get-sessionvars self)) + (globalvars (sdat-get-globalvars self)) + (page-name (sdat-get-page self)) + (session-key (sdat-get-session-key self)) (query (string-append "SELECT key,value FROM session_vars INNER JOIN sessions ON session_vars.session_id=sessions.id " "WHERE session_key=? AND page=?;"))) ;; first the page specific vars (dbi:for-each-row (lambda (tuple) @@ -374,32 +464,36 @@ (hash-table-set! globalvars k v))) conn (s:sqlparam query session-key "*globalvars")) )))) -(define-method (session:save-vars (self )) - (let ((session-id (slot-ref self 'session-id))) +(define (session:save-vars self) + (let ((session-id (sdat-get-session-id self))) (if (not session-id) (err:log "ERROR: No session id in session object! session:get-vars") (let* ((status #f) - (conn (slot-ref self 'conn)) - (page-name (slot-ref self 'page)) + (conn (sdat-get-conn self)) + (page-name (sdat-get-page self)) (del-query "DELETE FROM session_vars WHERE session_id=? AND page=? AND key=?;") (ins-query "INSERT INTO session_vars (session_id,page,key,value) VALUES(?,?,?,?);") (upd-query "UPDATE session_vars set value=? WHERE key=? AND session_id=? AND page=?;") (changed-count 0)) ;; save the delta only (for-each (lambda (page) ;; page is: "*globalvars*" "*sessionvars*" or otherstring - (let* ((master-slot-name (cond - ((string=? page "*sessionvars*") 'sessionvars) - ((string=? page "*globalvars*") 'globalvars) - (else 'pagevars))) - (before-slot-name (string->symbol (string-append (symbol->string master-slot-name) - "-before"))) - (master-ht (slot-ref self master-slot-name)) - (before-ht (slot-ref self before-slot-name)) + (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) @@ -428,45 +522,12 @@ (s:sqlparam ins-query session-id page key master-value))) (else (err:log "Shouldn't get here"))))) all-keys))) ;; process all keys (list "*sessionvars*" "*globalvars*" page-name)))))) -;; ;; (print del-query) -;; (for-each -;; (lambda (page) -;; (pg:query-for-each (lambda (tuple) -;; (set! status #t)) -;; (s:sqlparam del-query session-id page-name) -;; conn)) -;; (list page-name "*sessionvars")) -;; ;; NOTE: The following approach is inefficient and a little dangerous. Need to keep -;; ;; two hashes, before and after and use the delta to drive updating the db OR -;; ;; even better move to using rpc with a central process for maintaining state -;; ;; write the session page specific vars to the db -;; (for-each (lambda (key) -;; (pg:query-for-each (lambda (tuple) -;; (set! status #t)) -;; (s:sqlparam ins-query session-id page-name -;; (s:any->string key) ;; just in case it is a symbol -;; (hash-table-ref pagevars key)) -;; conn)) -;; (hash-table-keys pagevars)) -;; ;; write the session specific vars to the db -;; ;; BUG!!! THIS IS LAZY AND WILL BREAK FOR SOMEONE ACCESSING THE SAME SESSION FROM TWO WINDOWS!!! -;; (for-each (lambda (key) -;; (pg:query-for-each (lambda (tuple) -;; (set! status #t)) -;; (s:sqlparam ins-query session-id "*sessionvars*" -;; (s:any->string key) ;; just in case it is a symbol -;; (hash-table-ref sessionvars key)) -;; conn)) -;; (hash-table-keys sessionvars)) -;; ;; global vars will require a little more care - delaying for now. -;; )))) - ;; (pg:sql-null-object? element) -(define-method (session:read-config (self )) +(define (session:read-config self) (let ((name (string-append "." (pathname-file (car (argv))) ".config"))) (if (not (file-exists? name)) (print name " not found at " (current-directory)) (let* ((fp (open-input-file name)) (initargs (read fp))) @@ -493,19 +554,31 @@ (res '())) (if (eof-object? hed) res (loop (read-line p)(append res (list hed))))))) +(define (process-port p) + (let ((e (interaction-environment))) + (map + (lambda (x) + (cond + ((list? x) x) + ((string? x) x) + (else '()))) + (port-map (lambda (s) + (eval s e)) + (lambda ()(read p)))))) + ;; May 2011, putting all pages into one directory for the following reasons: ;; 1. want filename to reflect page name (emacs limitation) ;; 2. that's it! no other reason. could make it configurable ... -(define-method (session:call-parts (self ) page parts) - (slot-set! self 'curr-page page) - ;; (session:log self "page-dir-style: " (slot-ref self 'page-dir-style)) - (let* ((dir-style ;; (equal? (slot-ref self 'page-dir-style) "onedir")) ;; flag #t for onedir, #f for old style - (slot-ref self 'page-dir-style)) - (dir (string-append (slot-ref self 'sroot) +(define (session:call-parts self page parts) + (sdat-set-curr-page! self page) + ;; (session:log self "page-dir-style: " (sdat-get-page-dir-style self)) + (let* ((dir-style ;; (equal? (sdat-get-page-dir-style self) "onedir")) ;; flag #t for onedir, #f for old style + (sdat-get-page-dir-style self)) + (dir (string-append (sdat-get-sroot self) (if dir-style (conc "/pages/") (conc "/pages/" page)))) (control (string-append dir (if dir-style (conc page "_ctrl.scm") @@ -525,12 +598,13 @@ (begin (load control) (session:set-called! self page))) ;; move this to where it gets exectuted only once ;; + ;;(s:log "s:b yields " (s:b "blah")) (if load-view - ;; option one.: + ;; option one: ;; ;; (let ((inp (open-input-string ;; (files-read->string "/home/matt/kiatoa/stml/sugar.scm" ;; view)))) ;; (map @@ -544,42 +618,43 @@ ;; ;; option two: ;; (let* (;; (inps (map open-input-file (list view))) ;; sugar view))) (p (open-input-file view)) ;; (apply make-concatenated-port inps)) - (dat (map - (lambda (x) - (cond - ((list? x) x) - ((string? x) x) - (else '()))) - (port-map eval (lambda ()(read p)))))) + (dat (process-port p))) + ;;(map + ;; (lambda (x) + ;; (cond + ;; ((list? x) x) + ;; ((string? x) x) + ;; (else '()))) + ;; (port-map eval (lambda ()(read p)))))) ;; (map close-input-port inps) (close-input-port p) dat) (list "

Page not found " page "

")))) -(define-method (session:call (self ) page) - (session:call-parts self page 'both)) +;;(define (session:call self page) +;; (session:call-parts self page 'both)) -(define-method (session:call (self ) page parts) +(define (session:call self page parts) (session:call-parts self page 'both)) -(define-method (session:load-model (self ) model) - (let ((model.scm (string-append (slot-ref self 'sroot) "/models/" model ".scm")) - (model.so (string-append (slot-ref self 'sroot) "/models/" model ".so"))) +(define (session:load-model self model) + (let ((model.scm (string-append (sdat-get-sroot self) "/models/" model ".scm")) + (model.so (string-append (sdat-get-sroot self) "/models/" model ".so"))) (if (file-exists? model.so) (load model.so) (if (file-exists? model.scm) (load model.scm) (s:log "ERROR: model " model.scm " not found"))))) -(define-method (session:model-path (self ) model) - (string-append (slot-ref self 'sroot) "/models/" model ".scm")) +(define (session:model-path self model) + (string-append (sdat-get-sroot self) "/models/" model ".scm")) -(define-method (session:pp-formdat (self )) - (let ((dat (formdat:all->strings (slot-ref self 'formdat)))) +(define (session:pp-formdat self) + (let ((dat (formdat:all->strings (sdat-get-formdat self)))) (string-intersperse dat "
"))) (define (session:param->string params) ;; (err:log "params=" params) (if (< (length params) 1) @@ -592,59 +667,59 @@ result))) (if (< (length tail) 1) ;; true if done (string-intersperse newresult "&") (loop (car tail)(cadr tail)(cddr tail) newresult)))))) -(define-method (session:link-to (self ) page params) - (let* ((server (if (getenv "HTTP_HOST") - (getenv "HTTP_HOST") - (getenv "SERVER_NAME"))) - (script (let ((script-name (string-split (getenv "SCRIPT_NAME") "/"))) +(define (session:link-to self page params) + (let* ((server (if (get-environment-variable "HTTP_HOST") + (get-environment-variable "HTTP_HOST") + (get-environment-variable "SERVER_NAME"))) + (script (let ((script-name (string-split (get-environment-variable "SCRIPT_NAME") "/"))) (if (> (length script-name) 1) (string-append (car script-name) "/" (cadr script-name)) - (getenv "SCRIPT_NAME")))) ;; build script name from first two elements. This is a hangover from before I used ? in the URL. - (session-key (slot-ref self 'session-key)) + (get-environment-variable "SCRIPT_NAME")))) ;; build script name from first two elements. This is a hangover from before I used ? in the URL. + (session-key (sdat-get-session-key self)) (paramstr (session:param->string params))) ;; (session:log self "server=" server " script=" script " page=" page) (string-append "http://" server "/" script "/" page "?" paramstr))) ;; "/sn=" session-key))) -(define-method (session:cgi-out (self )) - (let* ((content (list (slot-ref self 'content-type))) ;; '("Content-type: text/html; charset=iso-8859-1\n\n")) - (header (let ((cookie (slot-ref self 'session-cookie))) +(define (session:cgi-out self) + (let* ((content (list (sdat-get-content-type self))) ;; '("Content-type: text/html; charset=iso-8859-1\n\n")) + (header (let ((cookie (sdat-get-session-cookie self))) (if cookie (cons (string-append "Set-Cookie: " (car cookie)) content) content))) - (pagedat (slot-ref self 'pagedat))) + (pagedat (sdat-get-pagedat self))) (s:cgi-out (cons header pagedat)))) -(define-method (session:log (self ) . msg) - (with-output-to-port (slot-ref self 'log-port) ;; (slot-ref self 'logpt) +(define (session:log self . msg) + (with-output-to-port (sdat-get-log-port self) ;; (sdat-get-logpt self) (lambda () (apply print msg)))) -(define-method (session:get-param (self ) key) +(define (session:get-param self key) ;; (session:log s:session "params=" (slot-ref s:session 'params)) - (let ((params (slot-ref self 'params))) + (let ((params (sdat-get-params self))) (session:get-param-from params key))) ;; This one will get the first value found regardless of form -(define-method (session:get-input (self ) key) - (let* ((formdat (slot-ref self 'formdat))) +(define (session:get-input self key) + (let* ((formdat (sdat-get-formdat self))) (if (not formdat) #f (if (or (string? key)(number? key)(symbol? key)) (if (eq? (class-of formdat) ) (formdat:get formdat key) (begin (session:log self "ERROR: formdat: " formdat " is not of class ") #f)) (session:log self "ERROR: bad key " key))))) -(define-method (session:run-actions (self )) +(define (session:run-actions self) (let* ((action (session:get-param self 'action)) - (page (slot-ref self 'page))) + (page (sdat-get-page self))) ;; (print "action=" action " page=" page) (if action (let ((action-lst (string-split action "."))) ;; (print "action-lst=" action-lst) (if (not (= (length action-lst) 2)) @@ -665,30 +740,30 @@ ((exn file) (s:log "file error")) ((exn i/o) (s:log "i/o error")) ((exn ) (s:log "Action not implemented: " proc-name " action: " targ-action)) (var () (s:log "Unknown Error")))))))))) -(define-method (session:never-called-page? (self ) page) +(define (session:never-called-page? self page) (session:log self "Checking for page: " page) - (not (member page (slot-ref self 'seen-pages)))) + (not (member page (sdat-get-seen-pages self)))) -(define-method (session:set-called! (self ) page) - (slot-set! self 'seen-pages (cons page (slot-ref self 'seen-pages)))) +(define (session:set-called! self page) + (sdat-set-seen-pages! self (cons page (sdat-get-seen-pages self)))) ;;====================================================================== ;; Alternative data type delivery ;;====================================================================== -(define-method (session:alt-out (self )) - (let ((dat (slot-ref self 'alt-page-dat))) +(define (session:alt-out self) + (let ((dat (sdat-get-alt-page-dat self))) ;; (s:log "dat is: " dat) ;; (print "HTTP/1.1 200 OK") (print "Date: " (time->string (seconds->utc-time (current-seconds)))) - (print "Content-Type: " (slot-ref self 'content-type)) + (print "Content-Type: " (sdat-get-content-type self)) (print "Accept-Ranges: bytes") (print "Content-Length: " (if (blob? dat) (blob-size dat) 0)) (print "Keep-Alive: timeout=15, max=100") (print "Connection: Keep-Alive") (print "") (write-string (blob->string dat) #f (current-output-port)))) Index: setup.scm ================================================================== --- setup.scm +++ setup.scm @@ -1,16 +1,20 @@ -;; Copyright 2007-2008, Matthew Welland. +;; Copyright 2007-2011, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. +(declare (unit setup)) +(declare (uses session)) + ;; -(define s:session (make )) +(define s:session (make-sdat)) +(session:initialize s:session) ;; use this for getting data from page to page when scope and evals ;; get in the way (define s:local-vars (make-hash-table)) @@ -26,28 +30,28 @@ (apply session:log s:session msg)) (session:get-vars s:session) (define (s:set-err . args) - (slot-set! s:session 'curr-err args)) + (sdat-set-curr-err s:session args)) ;; Usage: (s:get-err s:big) (define (s:get-err wrapperfunc) - (let ((errmsg (slot-ref s:session 'curr-err))) + (let ((errmsg (sdat-get-curr-err s:session))) (if errmsg ((if wrapperfunc wrapperfunc s:strong) errmsg) '()))) (define (s:current-page) - (slot-ref s:session 'page)) + (sdat-get-page s:session)) (define (s:delete-session) - (session:delete-session s:session (slot-ref s:session 'session-key))) + (session:delete-session s:session (sdat-get-session-key s:session))) (define (s:call page . partsl) (if (null? partsl) - (session:call s:session page) + (session:call s:session page #f) (session:call s:session page (car partsl)))) (define (s:link-to page . params) (session:link-to s:session page params)) @@ -93,10 +97,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: sqlite3.scm ================================================================== --- sqlite3.scm +++ sqlite3.scm @@ -1,6 +1,6 @@ -;; Copyright 2007-2008, Matthew Welland. +;; Copyright 2007-2011, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the Index: sqltbl.scm ================================================================== --- sqltbl.scm +++ sqltbl.scm @@ -1,94 +1,113 @@ -;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved. +;; Copyright 2007-2011, Matthew Welland. Kiatoa.com All rights reserved. ;; ;; DON'T USE THIS!!!! It was a bad idea :-( -;; If performance becomes an issue upgrade this to use a vector to - -(require-extension tinyclos) - -(define-class () - (rows - fields ;; list of field - fields-hash ;; hash of fields -> number - query ;; query string using ?'s - query-params ;; list of params for the query - conn ;; connection to db - num-rows ;; whatever - curr-row-ptr ;; number of the current row - curr-row ;; the current row vector (?? do we really want this ??) - )) - -(define-method (initialize (self ) initargs) - (call-next-method) - (slot-set! self 'num-rows 0) - (slot-set! self 'curr-row-ptr 0) - (slot-set! self 'fields '()) - (slot-set! self 'fields-hash (make-hash-table)) - (initialize-slots self initargs)) -;; (if (> (length (slot-ref self 'rows) 0)) -;; (slot-set! self 'curr-row (car rows)))) - -(define-method (sqltbl:next-row (self )) - (let ((curr-row-ptr (+ (slot-ref self 'curr-row-ptr) 1)) - (num-rows (slot-ref self 'num-rows)) - (rows (slot-ref self 'rows))) - (if (> curr-row-prt (slot-ref self 'num-rows)) #f ;; there is no next row +;; (require-extension tinyclos) + +;; (define-class () +;; (rows +;; fields ;; list of field +;; fields-hash ;; hash of fields -> number +;; query ;; query string using ?'s +;; query-params ;; list of params for the query +;; conn ;; connection to db +;; num-rows ;; whatever +;; curr-row-ptr ;; number of the current row +;; curr-row ;; the current row vector (?? do we really want this ??) +;; )) + +(declare (unit sqltbl)) + +(define (make-sqltbl:tbl)(make-vector 9)) +(define-inline (sqltbl:tbl-get-rows vec) (vector-ref vec 0)) +(define-inline (sqltbl:tbl-get-fields vec) (vector-ref vec 1)) +(define-inline (sqltbl:tbl-get-fields-hash vec) (vector-ref vec 2)) +(define-inline (sqltbl:tbl-get-query vec) (vector-ref vec 3)) +(define-inline (sqltbl:tbl-get-query-params vec) (vector-ref vec 4)) +(define-inline (sqltbl:tbl-get-conn vec) (vector-ref vec 5)) +(define-inline (sqltbl:tbl-get-num-rows vec) (vector-ref vec 6)) +(define-inline (sqltbl:tbl-get-curr-row-ptr vec) (vector-ref vec 7)) +(define-inline (sqltbl:tbl-get-curr-row vec) (vector-ref vec 8)) +(define-inline (sqltbl:tbl-set-rows! vec val)(vector-set! vec 0 val)) +(define-inline (sqltbl:tbl-set-fields! vec val)(vector-set! vec 1 val)) +(define-inline (sqltbl:tbl-set-fields-hash! vec val)(vector-set! vec 2 val)) +(define-inline (sqltbl:tbl-set-query! vec val)(vector-set! vec 3 val)) +(define-inline (sqltbl:tbl-set-query-params! vec val)(vector-set! vec 4 val)) +(define-inline (sqltbl:tbl-set-conn! vec val)(vector-set! vec 5 val)) +(define-inline (sqltbl:tbl-set-num-rows! vec val)(vector-set! vec 6 val)) +(define-inline (sqltbl:tbl-set-curr-row-ptr! vec val)(vector-set! vec 7 val)) +(define-inline (sqltbl:tbl-set-curr-row! vec val)(vector-set! vec 8 val)) + +(define (sqltbl:initialize self);; initargs) + (sqltbl:tbl-set-num-rows! self 0) + (sqltbl:tbl-set-curr-row-ptr! self 0) + (sqltbl:tbl-set-fields! self '()) + (sqltbl:tbl-set-fields-hash! self (make-hash-table))) + ;; (initialize-slots self initargs)) +;; (if (> (length (sqltbl:tbl-get-rows self) 0)) +;; (sqltbl:tbl-set-curr-row! self (car rows)))) + +(define (sqltbl:next-row self) + (let ((curr-row-ptr (+ (sqltbl:tbl-get-curr-row-ptr self) 1)) + (num-rows (sqltbl:tbl-get-num-rows self)) + (rows (sqltbl:tbl-get-rows self))) + (if (> curr-row-prt (sqltbl:tbl-get-num-rows self)) #f ;; there is no next row (let ((new-curr-row (list-ref rows curr-row-ptr))) - (slot-set! self 'curr-row new-curr-row) - (slot-set! self 'curr-row-prt curr-row-prt) + (sqltbl:tbl-set-curr-row! self new-curr-row) + (sqltbl:tbl-set-curr-row-prt! self curr-row-prt) new-curr-row)))) ;; run the query and fill the rows list -(define-method (sqltbl:run-query (self ) . params) - (let* ((query (slot-ref self 'query)) - (fields (slot-ref self 'fields)) +(define (sqltbl:run-query self . params) + (let* ((query (sqltbl:tbl-get-query self)) + (fields (sqltbl:tbl-get-fields self)) (rows (let ((result '()) (actual-query (apply s:sqlparam query fields params))) ;; (s:log "actual-query=" actual-query) (dbi:for-each-row (lambda (tuple) (set! result (cons tuple result))) - (slot-ref self 'conn) + (sqltbl:tbl-get-conn self) actual-query) - (slot-set! self 'query-params params) - (slot-set! self 'num-rows (length result)) + (sqltbl:tbl-set-query-params! self params) + (sqltbl:tbl-set-num-rows! self (length result)) (sqltbl:setup-fields self) ;; update the fields lookup hash (reverse result)))) - (slot-set! self 'rows rows) + (sqltbl:tbl-set-rows! self rows) (if (not (null? rows)) - (slot-set! self 'curr-row (car rows))) - (slot-set! self 'curr-row-ptr 0) + (sqltbl:tbl-set-curr-row! self (car rows))) + (sqltbl:tbl-set-curr-row-ptr! self 0) rows)) -(define-method (sqltbl:setup-fields (self )) - (let ((fields-hash (slot-ref self 'fields-hash)) - (fields-list (slot-ref self 'fields))) +(define (sqltbl:setup-fields self) + (let ((fields-hash (sqltbl:tbl-get-fields-hash self)) + (fields-list (sqltbl:tbl-get-fields self))) (let loop ((head (car fields-list)) (tail (cdr fields-list)) (fnum 0)) (hash-table-set! fields-hash head fnum) (if (null? tail) fnum (loop (car tail)(cdr tail)(+ fnum 1)))))) ;; get a value from the current row -(define-method (sqltbl:get-field-value-curr (self ) field) - (let ((curr-row (slot-ref self 'curr-row)) - (field-num (hash-table-ref/default (slot-ref self 'fields-hash) field #f))) +(define (sqltbl:get-field-value-curr self field) + (let ((curr-row (sqltbl:tbl-get-curr-row self)) + (field-num (hash-table-ref/default (sqltbl:tbl-get-fields-hash self) field #f))) (if field-num (vector-ref curr-row field-num) #f))) ;; not found -> #f -(define-method (sqltbl:vector->hash (self ) vec) +(define (sqltbl:vector->hash self vec) (let ((h (make-hash-table)) - (fields (slot-ref self 'fields))) + (fields (sqltbl:tbl-get-fields self))) (do ((i 0 (+ i 1))) ((>= i (length fields))) (hash-table-set! h (list-ref fields i)(vector-ref vec i))) h)) ;; runs proc on each row and returns the resulting list -(define-method (sqltbl:map (self ) proc) +(define (sqltbl:map self proc) (map (lambda (row) - (proc (sqltbl:vector->hash self row))) (slot-ref self 'rows))) + (proc (sqltbl:vector->hash self row))) (sqltbl:tbl-get-rows self))) Index: stml.config.template ================================================================== --- stml.config.template +++ stml.config.template @@ -1,8 +1,8 @@ -(list sroot "/path/to/{pages,models}/dir" - logfile "/tmp/stmlrun/logs.log" ;; this is now required! - dbtype 'sqlite3 ;; or 'pg - dbinit '((dbname . "test-stml.db") - (user . "nobody") - (password . "Dapassword") - (host . "localhost")) - domain "192.168.1.150") +'(sroot "/path/to/{pages,models}/dir" + logfile "/tmp/stmlrun/logs.log" + dbtype sqlite3 + dbinit ((dbname . "test-stml.db") + (user . "nobody") + (password . "Dapassword") + (host . "localhost")) + domain "192.168.1.150") Index: stml.scm ================================================================== --- stml.scm +++ stml.scm @@ -1,6 +1,6 @@ -;; Copyright 2007-2008, Matthew Welland. +;; Copyright 2007-2011, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the @@ -7,10 +7,13 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;; stml is a list of html strings +(declare (unit stml)) +(declare (uses misc-stml)) + ;; extract various tokens from the parameter list ;; 'key val => put in the params list ;; strings => maintain order and add to the datalist <<== IMPORTANT (define (s:extract inlst) (if (null? inlst) inlst Index: stmlrun.scm ================================================================== --- stmlrun.scm +++ stmlrun.scm @@ -1,48 +1,47 @@ #!/usr/local/bin/csi -q -;; Copyright 2007-2008, Matthew Welland. +;; Copyright 2007-2011, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;; (require-extension syntax-case) -(declare (run-time-macros)) +;; (declare (run-time-macros)) -(use dbi) +(require-library dbi) (include "requirements.scm") -(include "html-filter.scm") -(include "misc-stml.scm") -(include "formdat.scm") -(include "stml.scm") -;; (include "dbi.scm") -(include "session.scm") -(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)) - -;; (s:log "HTTP_COOKIE" (getenv "HTTP_COOKIE")) +(include "cookie.scm") +(declare (uses html-filter)) +(declare (uses misc-stml)) +(declare (uses formdat)) +(declare (uses stml)) +(declare (uses session)) +(declare (uses setup)) ;; s:session gets created here +(declare (uses sqltbl)) +(declare (uses keystore)) + +(sdat-set-log-port! s:session ;; (current-error-port)) + (open-output-file (sdat-get-logfile s:session) #:append)) + +;; (s:log "HTTP_COOKIE" (get-environment-variable "HTTP_COOKIE")) ;; (s:log "stdin-dat=" (slot-ref s:session 'stdin-dat)) (s:validate-inputs) (session:run-actions s:session) -(slot-set! s:session 'pagedat - (append (slot-ref s:session 'pagedat) - (s:call (slot-ref s:session 'toppage)))) +(sdat-set-pagedat! s:session + (append (sdat-get-pagedat s:session) + (s:call (sdat-get-toppage s:session)))) -(if (eq? (slot-ref s:session 'page-type) 'html) ;; default is html. +(if (eq? (sdat-get-page-type s:session) 'html) ;; default is html. (session:cgi-out s:session) (session:alt-out s:session)) (session:save-vars s:session) Index: sugar.scm ================================================================== --- sugar.scm +++ sugar.scm @@ -1,6 +1,6 @@ -;; Copyright 2007-2008, Matthew Welland. +;; Copyright 2007-2011, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ADDED test.scm Index: test.scm ================================================================== --- /dev/null +++ test.scm @@ -0,0 +1,22 @@ +(use test md5) + +(require-extension sqlite3) +(import (prefix sqlite3 sqlite3:)) + +(require-library dbi) + +;; (declare (uses stml)) + +(include "requirements.scm") +(include "cookie.scm") +(include "misc-stml.scm") +(include "formdat.scm") +(include "stml.scm") +(include "session.scm") +(include "sqltbl.scm") +(include "html-filter.scm") +(include "keystore.scm") + +(define p (open-input-file "test.stml")) +(print (process-port p)) +(close-input-port p) ADDED test.stml Index: test.stml ================================================================== --- /dev/null +++ test.stml @@ -0,0 +1,10 @@ +;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved. +;; +;; index + +(list + (s:html + (s:head + (s:title "Kiatoa") + (s:link 'rel "stylesheet" 'type "text/css" 'href "/kiatoa/markup.css") + (s:link 'rel "stylesheet" 'type "text/css" 'href "/kiatoa/layout.css")))) Index: tests/test.scm ================================================================== --- tests/test.scm +++ tests/test.scm @@ -7,13 +7,19 @@ ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. -(use test md5 dbi) +(use test md5) + +(require-extension sqlite3) +(import (prefix sqlite3 sqlite3:)) + +(require-library dbi) (load "./requirements.scm") +(load "./cookie.so") (load "./misc-stml.scm") (load "./formdat.scm") (load "./stml.scm") (load "./session.scm") (load "./sqltbl.scm") @@ -75,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))) @@ -114,11 +120,11 @@ (test "misc:non-zero-string #f" #f (misc:non-zero-string #f)) (test "misc:non-zero-string 'blah" #f (misc:non-zero-string 'blah)) ;; forms (define form #f) -(test "make " #t (let ((f (make ))) +(test "make " #t (let ((f (make-formdat:formdat))) (set! form f) #t)) (test "formdat: set!/get" "Yep!" (begin (formdat:set! form "blah" "Yep!") (formdat:get form "blah")))