Changes In Branch move-to-ck4.7.x Through [31955e0a02] Excluding Merge-Ins

This is equivalent to a diff from 3217617d70 to 31955e0a02

2011-10-04
14:42
Merged changes for chicken4.7 to trunk check-in: fda7f57df0 user: mrwellan tags: trunk
05:33
99.99% complete in porting to chicken 4.7 check-in: 06b806d3c6 user: matt tags: move-to-ck4.7.x
03:39
Moved to units based compilation check-in: 31955e0a02 user: matt tags: move-to-ck4.7.x
02:58
couple files to help recreate the eval problem check-in: 2be28d85ad user: matt tags: move-to-ck4.7.x
2011-10-02
03:48
Create new branch named "move-to-ck4.7.x" check-in: 79392b09d0 user: matt tags: move-to-ck4.7.x
2011-09-25
03:33
Cleaned up twiki, no more table based layout. Also no documentation yet... check-in: 3217617d70 user: matt tags: trunk
2011-09-24
22:13
Yikes. Changes sitting around on disk for long time.... s:any->pgint fix? check-in: 7807ffe39b user: matt tags: trunk

Modified Makefile from [1d36e0d212] to [c46021886f].

1
2
3
4
5
6
7
8
9
10
11

12
13
14
15
16
17
18
19
20


21
22
23
24
25
26
27
28
29
30
31
32
33
34
35



36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51

52


53
54
55
56
57
58
59
60
61
62
63
64
65
# Copyright 2007-2008, 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 install.cfg


MODULEFILES = $(wildcard modules/*/*-mod.scm)
SOFILES     = $(MODULEFILES:%.scm=%.so)
CFILES      = $(MODULEFILES:%.scm=%.c)
OFILES      = $(MODULEFILES:%.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


$(TARGDIR)/stmlrun : stmlrun 
	cp stmlrun $(TARGDIR)
	chmod a+rx $(TARGDIR)/stmlrun

$(TARGDIR)/modules :
	mkdir -p $(TARGDIR)/modules

$(MODULES) : $(SOFILES) $(TARGDIR)/modules
	cp $< $@




# logging currently relies on this
#
$(LOGDIR) :
	mkdir -p $(LOGDIR)
	chmod a+rwx $(LOGDIR)

test: kiatoa.db
	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/
# 
# $(CFILES): build/%.c: ../scm/%.scm ../scm/macros.scm
# 	chicken $< -output-file $@
# 
# 
# $(OFILES): src/%.o: src/%.c
# 	gcc -c $< `chicken-config -cflags` -o $@
# 











>



|





>
>
|
|
|
|
<










>
>
>







|







|
>

>
>
|
|

<
<
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27

28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63


64
65
66
67
68
69
70
71
# Copyright 2007-2008, 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 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      = $(SRCFILES:%.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 \
#           cookie.scm sqltbl.scm
# 	csc stmlrun.scm


$(TARGDIR)/stmlrun : stmlrun 
	cp stmlrun $(TARGDIR)
	chmod a+rx $(TARGDIR)/stmlrun

$(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 cookie.so
	echo '(exit)'| csi -q  ./tests/test.scm 

# modules
#
%.so : %.scm
	csc -I modules/* -s $<

%.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
# 	gcc -c $< `chicken-config -cflags` -o $@
# 

Added cookie.scm version [599d58e819].

























































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
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
;;   <ftp://ftp.isi.edu/in-notes/rfc2965.txt>
;; See also
;; RFC 2964 Use of HTTP state management
;;   <ftp://ftp.isi.edu/in-notes/rfc2964.txt>
;; The parser also supports the old Netscape spec
;;   <http://www.netscape.com/newsref/std/cookie_spec.html>

(declare (unit cookie))
(require-extension srfi-1 srfi-13 srfi-14 regex)
(declare (export parse-cookie-string construct-cookie-string))

#>
#include <time.h>
<#

(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.
;;   ((<name> <value> [:path <path>] [:domain <domain>] [:port <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.
;;
;;   ((<name> <value> [:comment <comment>] [:comment-url <comment-url>]
;;                    [:discard <bool>] [:domain <domain>]
;;                    [:max-age <age>] [:path <value>] [:port <port-list>]
;;                    [:secure <bool>] [:version <version>] [:expires <date>]
;;    ) ...)
;;
;; Returns a list of cookie strings for each <name>=<value> 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 <name> and <value> 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)))

Modified formdat.scm from [556fae5e96] to [3d0d733457].

1
2
3
4
5
6
7
8
9

10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27



28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
;; Copyright 2007-2008, 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")

(define formdat:*debug* #f)

;; Old data format was something like this. BUT! 
;; Forms do not have names so the hierarcy is
;; unnecessary (I think)
;;
;; hashtable
;;   |-formname --> <formdat> 'form-name=formname
;;   |                        'form-data=hashtable
;;   |                                       | name => value
;;
;; New data format is only the <formdat> portion from above

(define-class <formdat> ()
   (form-data
   ))




(define-method (initialize (self <formdat>) initargs)
  (call-next-method)
  (slot-set! self 'form-data (make-hash-table))
  (initialize-slots self initargs))

(define-method (formdat:get (self <formdat>) key)
  (hash-table-ref/default (slot-ref self 'form-data) key #f))

;; change to convert data to list and append val if already exists
;; or is a list
(define-method (formdat:set! (self <formdat>) key val)
  (let ((prev-val (formdat:get self key))
        (ht       (slot-ref self 'form-data)))
    (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 <formdat>))
  (hash-table-keys (slot-ref self 'form-data)))

(define-method (formdat:printall (self <formdat>) 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 <formdat>))
  (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 <formdat>) formlist)
  (let ((ht             (slot-ref self 'form-data)))
    (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)))
            ;; (err:log "key=" key " val=" val)
	    (if (> (length val) 1)
|








>
|














|
|
|
>
>
>

|
<
|
<

|
|



|

|







|
|

|





|







|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33

34

35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
;; 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 formdat))
(use regex)

(define formdat:*debug* #f)

;; Old data format was something like this. BUT! 
;; Forms do not have names so the hierarcy is
;; unnecessary (I think)
;;
;; hashtable
;;   |-formname --> <formdat> 'form-name=formname
;;   |                        'form-data=hashtable
;;   |                                       | name => value
;;
;; New data format is only the <formdat> portion from above

;; (define-class <formdat> ()
;;    (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 (formdat:set! self key val)
  (let ((prev-val (formdat:get self key))
        (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 (formdat:keys self)
  (hash-table-keys (formdat:formdat-get-data self)))

(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 (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 (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)))
            ;; (err:log "key=" key " val=" val)
	    (if (> (length val) 1)
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
(define formdat:bin-data-name-rex (regexp "\\Wname=\"([^\"]+)\""))
(define formdat:bin-file-name-rex (regexp "\\Wfilename=\"([^\"]+)\""))
(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")))
    (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 <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)
      (let ((firstitem   (car alldats))
	    (multipass #f)) 







|






|







146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
(define formdat:bin-data-name-rex (regexp "\\Wname=\"([^\"]+)\""))
(define formdat:bin-file-name-rex (regexp "\\Wfilename=\"([^\"]+)\""))
(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 (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-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)
      (let ((firstitem   (car alldats))
	    (multipass #f)) 

Modified html-filter.scm from [0b79e98f29] to [be2e4e1457].

1
2
3
4
5
6
7
8


9
10
11
12
13
14
15
;; Copyright 2007-2008, 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.



;; 
(define (s:split-string strng delim)
  (if (eq? (string-length strng) 0) (list strng)
      (let loop ((head (make-string 1 (car (string->list strng))))
		 (tail (cdr (string->list strng)))
		 (dest '())
|







>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
;; 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))))
		 (tail (cdr (string->list strng)))
		 (dest '())

Modified keystore.scm from [e9c191141b] to [1e4a5aef9c].

1
2
3
4
5
6
7
8
9
10
11
12
13


14
15
16
17
18
19
20
;; Copyright 2007-2008, 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.

;;======================================================================
;; The meta data key store, just a general dumping ground for values
;; only used occasionally
;;======================================================================



(define (keystore:get db key)
  (dbi:get-one db "SELECT value FROM metadata WHERE key=?;" key))

(define (keystore:set! db key value)
  (let ((curr-val (keystore:get db key)))
    (if curr-val
|












>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
;; 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.

;;======================================================================
;; 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)
  (let ((curr-val (keystore:get db key)))
    (if curr-val

Modified misc-stml.scm from [97e4132f22] to [9d5a337236].

1
2
3
4
5
6
7
8
9
10
11
12



13
14
15
16
17
18
19
;; Copyright 2007-2008, 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.

;;======================================================================
;; dumbobj helpers
;;======================================================================




;; 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))
             (tail (cdr lst))
             (fnum 0))
|











>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
;; 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.

;;======================================================================
;; 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))
             (tail (cdr lst))
             (fnum 0))
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
		   (s:html (s:head 
			    (s:title err)
			    (s:body
			     (s:h1 "ERROR")
			     (s:p err)))))))

(define (s:validate-uri)
  (let ((uri (getenv "REQUEST_URI"))
	(qrs (getenv "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)
	(begin
	  (s:log "REQUEST URI NOT AVAILABLE!")
	  (let ((p (open-input-pipe "env")))
	    (let loop ((l (read-line p))
		       (res '()))
	      (if (eof-object? l)
		  (s:log res)
		  (loop (read-line p)(cons (list l "<BR>") res)))))
	  #t))))

(define (s:validate-inputs)
  (if (not (s:validate-uri))(begin (s:error-page "Bad URI" (let ((ref (getenv "HTTP_REFERER")))
							     (if ref
								 (list "referred from" ref)
								 "")))
				   (exit))))

;; anything except a list is converted to a string!!!
(define (s:any->string val)







|
|
















|







150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
		   (s:html (s:head 
			    (s:title err)
			    (s:body
			     (s:h1 "ERROR")
			     (s:p err)))))))

(define (s:validate-uri)
  (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)
	(begin
	  (s:log "REQUEST URI NOT AVAILABLE!")
	  (let ((p (open-input-pipe "env")))
	    (let loop ((l (read-line p))
		       (res '()))
	      (if (eof-object? l)
		  (s:log res)
		  (loop (read-line p)(cons (list l "<BR>") res)))))
	  #t))))

(define (s:validate-inputs)
  (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))))

;; anything except a list is converted to a string!!!
(define (s:any->string val)

Modified session.scm from [1d8ba11dc5] to [0524c59e8f].

1
2
3
4
5
6
7
8
9

10


11
12
13
14
15
16
17
18
19
20
21
22
23
24

25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41




































































42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83


84
85

86
87

88
89






90
91


92



93





94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
;; Copyright 2007-2008, 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")



;; sessions table
;; id session_id session_key
;; create table sessions (id serial not null,session-key text);

;; session_vars table
;; id session_id page_id key value
;; create table session_vars (id serial not null,session_id integer,page text,key text,value text);

;; 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 <session> ()
  (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 <session>) 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/<pagename>_(view|cntl).scm
                                      ;; #f : pages/<pagename>/(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 <session>))
  (let ((dbtype (slot-ref self 'dbtype))
	(dbinit (eval (slot-ref self 'dbinit)))
	(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))
    (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))))

;; setup the db with session tables, works for sqlite only right now
(define-method (session:setup-db (self <session>))
  (let ((conn (slot-ref self 'conn)))
    (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)))

;; only set session-cookie when a new session is created
(define-method (session:setup-session-key (self <session>))  
  (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))))

(define-method (session:make-cookie (self <session>))
  ;; (list (conc "session_key=" (slot-ref self 'session-key) "; Path=/; Domain=." (slot-ref self 'domain) "; 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)
		  expires: ,(+ (current-seconds) (* 14 86400)) 
		  max-age: (* 14 86400)
		  path: "/" ;; 
		  domain: ,(string-append "." (slot-ref self 'domain))
		  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>) session-key)
  ;; (let ((session-key (slot-ref self 'session-key)))
  (if session-key
      (let ((query (string-append "SELECT id FROM sessions WHERE session_key='" session-key "'"))
            (conn (slot-ref self 'conn))
            (result #f))
	(dbi:for-each-row 
	 (lambda (tuple)
	   (set! result (vector-ref tuple 0)))
	 conn query)
	(if result (dbi:exec conn (conc "UPDATE sessions SET last_used=" (dbi:now conn) " WHERE session_key=?;") session-key))
        result)
      #f))

;; 
(define-method (session:process-url-path (self <session>))
  (let ((path-info    (getenv "PATH_INFO"))
	(query-string (getenv "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)))
	  ;; (session:log self "url-path=" url-path " parts=" parts)
	  (if (> numparts 1)
	      (slot-set! self 'path-params (cdr parts)))
          (if query-string
              (slot-set! self 'params (string-split query-string "&")))))))

;; BUGGY!
(define-method (session:get-new-key (self <session>))
  (let ((conn   (slot-ref self 'conn))
        (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 <session>))
  (let ((http-session (getenv "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>) 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))
    ;;                        conn)
    (dbi:for-each-row (lambda (tuple)
			(set! result (vector-ref tuple 0))) ;; (vector-ref tuple 0)))
		      (slot-ref self 'conn)
		      (s:sqlparam query session-key))
    result))

;; delete all records for a session
;;
(define-method (session:delete-session (self <session>) 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)))
    (if session-id
        (begin
          (dbi:exec conn qry session-id session-id)
	  (initialize self '())
	  (session:setup self)))
    (not (session:get-session-id self session-key))))

;; (define-method (session:delete-session (self <session>) 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)))
;;     (if session-id
;;         (begin
;;           (for-each
;;            (lambda (query)
;;              (dbi:exec conn query session-id))
;; 	   queries)
;; 	  (initialize self '())
;; 	  (session:setup self)))
;;     (not (session:get-session-id self session-key))))

(define-method (session:extract-key (self <session>) key)
  (let ((params (slot-ref self 'params)))
    (session:extract-key-from-param self params key)))

(define-method (session:extract-key-from-param (self <session>) 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))
		session-key))
	     ((null? tail)
	      #f)
	     (else
	      (loop (car tail)
		    (cdr tail)))))))))

(define-method (session:set-page! (self <session>) page_name)
  (slot-set! self 'page page_name))

(define-method (session:close (self <session>))
  (dbi:close (slot-ref self 'conn)))
;; (close-output-port (slot-ref self 'logpt))

(define-method (session:err-msg (self <session>) msg)
  (hash-table-set! (slot-ref self 'sessionvars) "ERROR_MSG"
		   (string-intersperse (map s:any->string msg) " ")))

(define-method (session:prev-err (self <session>))
  (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)))
    (if prev-err prev-err
	(if curr-err curr-err #f))))

;; session vars
;; 1. keys are always a string NOT a symbol
;; 2. values are always a string conversion is the responsibility of the 
;;    consuming function (at least for now, I'd like to change this)

;; set a session var for the current page
;;
(define-method (session:set! (self <session>) key value)
  (hash-table-set! (slot-ref self 'pagevars) (s:any->string key) (s:any->string value)))

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

;; get the appropriate hash given a page "*sessionvars*, *globalvars* or page
;;
(define-method (session:get-page-hash (self <session>) page)
  (if (string=? page "*sessionvars*")
      (slot-ref self 'sessionvars)
      (if (string=? page "*globalvars*")
	  (slot-ref self 'globalvars)
	  (slot-ref self 'pagevars))))

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

;; get session vars for a specified page
;;
(define-method (session:get (self <session>) 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 <session>) 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 <session>))
  (let ((session-id  (slot-ref self 'session-id)))
    (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))
	       (query              (string-append
				    "SELECT key,value FROM session_vars INNER JOIN sessions ON session_vars.session_id=sessions.id "
				    "WHERE session_key=? AND page=?;")))
	  ;; first the page specific vars
	  (dbi:for-each-row (lambda (tuple)
			      (let ((k (vector-ref tuple 0))
				    (v (vector-ref tuple 1)))
|








>
|
>
>














>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|


|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
>
>
|
|
>
|
|
>
|
<
>
>
>
>
>
>
|
|
>
>
|
>
>
>
|
>
>
>
>
>
|
|
|









|







|
|


|
|







|


|





|
|
|
|

|
|




|



|



|
|


|










|
|
|





|


|

|


|
|








|
|




|





|



|





|





|



|



|





|










|
|


|








|







|
|

|
|
|

|
|


|
|
|










|
|



|
|



|

|

|
|



|





|
|



|





|





|
|



|
|
|
|
|
|
|
|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133

134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163

164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
;; 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 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);

;; session_vars table
;; id session_id page_id key value
;; create table session_vars (id serial not null,session_id integer,page text,key text,value text);

;; TODO
;;  Concept of order num incremented with each page access
;;     if a branch is taken then a new session would need to be created
;;

;; make-vector-record session session dbtype dbinit conn params path-params session-key session-id domain toppage page curr-page content-type page-type sroot twikidir pagedat alt-page-dat pagevars pagevars-before sessionvars sessionvars-before globalvars globalvars-before logpt formdat request-method session-cookie curr-err log-port logfile seen-pages page-dir-style debugmode
(define (make-sdat)(make-vector 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 <session> ()
;;   (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 (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/<pagename>_(view|cntl).scm
                                      ;; #f : pages/<pagename>/(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
  (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))
      )
    (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
    (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)))
    (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)))

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

(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" ,(sdat-get-session-key self)
		  expires: ,(+ (current-seconds) (* 14 86400)) 
		  max-age: (* 14 86400)
		  path: "/" ;; 
		  domain: ,(string-append "." (sdat-get-domain self))
		  version: 1)) 0)))))

;; look up a given session key and return the id if found, #f if not found
(define (session:get-id self session-key)
  ;; (let ((session-key (sdat-get-session-key self)))
  (if session-key
      (let ((query (string-append "SELECT id FROM sessions WHERE session_key='" session-key "'"))
            (conn (sdat-get-conn self))
            (result #f))
	(dbi:for-each-row 
	 (lambda (tuple)
	   (set! result (vector-ref tuple 0)))
	 conn query)
	(if result (dbi:exec conn (conc "UPDATE sessions SET last_used=" (dbi:now conn) " WHERE session_key=?;") session-key))
        result)
      #f))

;; 
(define (session:process-url-path self)
  (let ((path-info    (get-environment-variable "PATH_INFO"))
	(query-string (get-environment-variable "QUERY_STRING")))
    ;; (session:log self "path-info=" path-info " query-string=" query-string)
    (if path-info
	(let* ((parts    (string-split path-info "/"))
	       (numparts (length parts)))
	  (if (> numparts 0)
	      (sdat-set-page! self (car parts)))
	  ;; (session:log self "url-path=" url-path " parts=" parts)
	  (if (> numparts 1)
	      (sdat-set-path-params! self (cdr parts)))
          (if query-string
              (sdat-set-params! self (string-split query-string "&")))))))

;; BUGGY!
(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 (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 (session:get-session-id self session-key)
  (let ((query "SELECT id FROM sessions WHERE session_key=?;")
        (result #f))
    ;;     (pg:query-for-each (lambda (tuple)
    ;;                          (set! result (vector-ref tuple 0))) ;; (vector-ref tuple 0)))
    ;;                        (s:sqlparam query session-key)
    ;;                        (sdat-get-conn self))
    ;;                        conn)
    (dbi:for-each-row (lambda (tuple)
			(set! result (vector-ref tuple 0))) ;; (vector-ref tuple 0)))
		      (sdat-get-conn self)
		      (s:sqlparam query session-key))
    result))

;; delete all records for a session
;;
(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              (sdat-get-conn self)))
    (if session-id
        (begin
          (dbi:exec conn qry session-id session-id)
	  (session:initialize self)
	  (session:setup self)))
    (not (session:get-session-id self session-key))))

;; (define (session:delete-session self session-key)
;;   (let ((session-id (session:get-session-id self session-key))
;;         (queries    (list "BEGIN;"
;; 			  "DELETE FROM session_vars WHERE session_id=?;"
;;                           "DELETE FROM sessions WHERE id=?;"
;; 			  "COMMIT;"))
;;         (conn              (sdat-get-conn self)))
;;     (if session-id
;;         (begin
;;           (for-each
;;            (lambda (query)
;;              (dbi:exec conn query session-id))
;; 	   queries)
;; 	  (initialize self '())
;; 	  (session:setup self)))
;;     (not (session:get-session-id self session-key))))

(define (session:extract-key self key)
  (let ((params (sdat-get-params self)))
    (session:extract-key-from-param self params key)))

(define (session:extract-key-from-param self params key)
  (let ((r1     (regexp (string-append "^" key "=([^=]+)$"))))
    (if (< (length params) 1) #f
	(let loop ((head   (car params))
		   (tail   (cdr params)))
	  (let ((match (string-match r1 head)))
	    (cond
	     (match
	      (let ((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 (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 (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
;; 2. values are always a string conversion is the responsibility of the 
;;    consuming function (at least for now, I'd like to change this)

;; set a session var for the current page
;;
(define (session: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 (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 (session:get-page-hash self page)
  (if (string=? page "*sessionvars*")
      (sdat-get-sessionvars self)
      (if (string=? page "*globalvars*")
	  (sdat-get-globalvars self)
	  (sdat-get-pagevars self))))

;; set a session var for a given page
;;
(define (session:set! self page key value)
  (let ((ht (session:get-page-hash self page)))
    (hash-table-set! ht (s:any->string key) (s:any->string value))))

;; get session vars for the current page
;;
(define (session:get self key)
  (hash-table-ref/default (sdat-get-pagevars self) key #f))

;; get session vars for a specified page
;;
(define (session:get self page key)
  (let ((ht (session:get-page-hash self page)))
    (hash-table-ref/default ht key #f)))

;; delete a session var for a specified page
;;
(define (session:del! self page key)
  (let ((ht (session:get-page-hash self page)))
    (hash-table-delete! ht 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)))
    (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))
	       (query              (string-append
				    "SELECT key,value FROM session_vars INNER JOIN sessions ON session_vars.session_id=sessions.id "
				    "WHERE session_key=? AND page=?;")))
	  ;; first the page specific vars
	  (dbi:for-each-row (lambda (tuple)
			      (let ((k (vector-ref tuple 0))
				    (v (vector-ref tuple 1)))
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394


395


396
397

398
399
400
401
402
403
404
405
406
407
				    (v (vector-ref tuple 1)))
				(hash-table-set! globalvars-before k v)
				(hash-table-set! globalvars        k v)))
			    conn
			    (s:sqlparam query session-key "*globalvars"))
	  ))))

(define-method (session:save-vars (self <session>))
  (let ((session-id  (slot-ref self 'session-id)))
    (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))
	       (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))
		    (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)
		  (let ((master-value (hash-table-ref/default master-ht key #f))
			(before-value (hash-table-ref/default before-ht key #f)))







|
|



|
|







|
|
>
>
|
>
>
|
<
>
|
|
|







462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490

491
492
493
494
495
496
497
498
499
500
501
				    (v (vector-ref tuple 1)))
				(hash-table-set! globalvars-before k v)
				(hash-table-set! globalvars        k v)))
			    conn
			    (s:sqlparam query session-key "*globalvars"))
	  ))))

(define (session:save-vars self)
  (let ((session-id  (sdat-get-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))
	       (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)))
				       ((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)
		  (let ((master-value (hash-table-ref/default master-ht key #f))
			(before-value (hash-table-ref/default before-ht key #f)))
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
					  (set! changed-count (+ changed-count 1)))
					conn
					(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 <session>))
  (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)))
	  (close-input-port fp)
	  initargs))))







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<

|







520
521
522
523
524
525
526

































527
528
529
530
531
532
533
534
535
					  (set! changed-count (+ changed-count 1)))
					conn
					(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))))))


































;; (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))
	(let* ((fp (open-input-file name))
	       (initargs (read fp)))
	  (close-input-port fp)
	  initargs))))
491
492
493
494
495
496
497












498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
  (let ((p (open-input-file f)))
    (let loop ((hed (read-line p))
	       (res '()))
      (if (eof-object? hed)
	  res
	  (loop (read-line p)(append res (list hed)))))))













;; 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 <session>) 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) 
				 (if dir-style 
				     (conc "/pages/")
				     (conc "/pages/" page))))
	 (control (string-append dir (if dir-style 
					 (conc page "_ctrl.scm")
					 "/control.scm")))
	 (view    (string-append dir (if dir-style 







>
>
>
>
>
>
>
>
>
>
>
>



|
|
|
|
|
|







552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
  (let ((p (open-input-file f)))
    (let loop ((hed (read-line p))
	       (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 (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")
					 "/control.scm")))
	 (view    (string-append dir (if dir-style 
523
524
525
526
527
528
529

530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549

550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
    ;; (print "dir=" dir " control=" control " view=" view " load-view=" load-view " load=control=" load-control)
    (if load-control
	(begin
	  (load control)
	  (session:set-called! self page)))
    ;; move this to where it gets exectuted only once
    ;;

    (if load-view
	;; option one.:
	;;
	;; (let ((inp (open-input-string 
	;; 	    (files-read->string "/home/matt/kiatoa/stml/sugar.scm" 
	;; 				view))))
	;;   (map 
	;;    (lambda (x)
	;;      (cond
	;;       ((list? x) x)
	;;       ((string? x) x)
	;;       (else '())))
	;;    (port-map eval (lambda ()
	;; 		 (read inp)))))
	;;
	;; 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))))))
	  ;; (map close-input-port inps)
	  (close-input-port p)
	  dat)
	(list "<p>Page not found " page " </p>"))))

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

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

(define-method (session:load-model (self <session>) model)
  (let ((model.scm (string-append (slot-ref self 'sroot) "/models/" model ".scm"))
	(model.so  (string-append (slot-ref self 'sroot) "/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 <session>) model)
  (string-append (slot-ref self 'sroot) "/models/" model ".scm"))

(define-method (session:pp-formdat (self <session>))
  (let ((dat (formdat:all->strings (slot-ref self 'formdat))))
    (string-intersperse dat "<br> ")))

(define (session:param->string params)
  ;; (err:log "params=" params)
  (if (< (length params) 1)
      ""
      (let loop ((key (car params))
		 (val (cadr params))
		 (tail (cddr params))
		 (result '()))
	(let ((newresult (cons (string-append (s:any->string key) "=" (s:any->string val))
			       result)))
	  (if (< (length tail) 1) ;; true if done
	      (string-intersperse newresult "&")
	      (loop (car tail)(cadr tail)(cddr tail) newresult))))))

(define-method (session:link-to (self <session>) page params)
  (let* ((server    (if (getenv "HTTP_HOST")
			(getenv "HTTP_HOST")
			(getenv "SERVER_NAME")))
	 (script (let ((script-name (string-split (getenv "SCRIPT_NAME") "/")))
		   (if (> (length script-name) 1)
		       (string-append (car script-name) "/" (cadr script-name))
		       (getenv "SCRIPT_NAME")))) ;; build script name from first two elements. This is a hangover from before I used ? in the URL.
	 (session-key (slot-ref self 'session-key))
	 (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 <session>))
  (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)))
		     (if cookie
			 (cons (string-append "Set-Cookie: " (car cookie))
			       content)
			 content)))
	 (pagedat  (slot-ref self 'pagedat)))
    (s:cgi-out 
     (cons header pagedat))))

(define-method (session:log (self <session>) . msg)
  (with-output-to-port (slot-ref self 'log-port) ;; (slot-ref self 'logpt)
    (lambda () 
      (apply print msg))))

(define-method (session:get-param (self <session>) key)
  ;; (session:log s:session "params=" (slot-ref s:session 'params))
  (let ((params (slot-ref self 'params)))
    (session:get-param-from params key)))

;; This one will get the first value found regardless of form
(define-method (session:get-input (self <session>) key)
  (let* ((formdat (slot-ref self 'formdat)))
    (if (not formdat) #f
	(if (or (string? key)(number? key)(symbol? key))
	    (if (eq? (class-of formdat) <formdat>)
		(formdat:get formdat key)
		(begin
		  (session:log self "ERROR: formdat: " formdat " is not of class <formdat>")
		  #f))
	    (session:log self "ERROR: bad key " key)))))

(define-method (session:run-actions (self <session>))
  (let* ((action    (session:get-param self 'action))
	 (page      (slot-ref self 'page)))
    ;; (print "action=" action " page=" page)
    (if action
	(let ((action-lst  (string-split action ".")))
	  ;; (print "action-lst=" action-lst)
	  (if (not (= (length action-lst) 2)) 
	      (err:log "Action should be of form: module.action")
	      (let* ((targ-page   (car action-lst))







>

|

















|
>
|
|
|
|
|
|





|
|

|


|
|
|






|
|

|
|
















|
|
|
|
|


|
|




|
|
|




|



|
|



|

|



|
|









|

|







596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
    ;; (print "dir=" dir " control=" control " view=" view " load-view=" load-view " load=control=" load-control)
    (if load-control
	(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:
	;;
	;; (let ((inp (open-input-string 
	;; 	    (files-read->string "/home/matt/kiatoa/stml/sugar.scm" 
	;; 				view))))
	;;   (map 
	;;    (lambda (x)
	;;      (cond
	;;       ((list? x) x)
	;;       ((string? x) x)
	;;       (else '())))
	;;    (port-map eval (lambda ()
	;; 		 (read inp)))))
	;;
	;; option two:
	;;
	(let* (;; (inps (map open-input-file (list view))) ;; sugar view)))
	       (p    (open-input-file view)) ;; (apply make-concatenated-port inps))
	       (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 "<p>Page not found " page " </p>"))))

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

(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")))
    (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"))

(define (session:pp-formdat self)
  (let ((dat (formdat:all->strings (sdat-get-formdat self))))
    (string-intersperse dat "<br> ")))

(define (session:param->string params)
  ;; (err:log "params=" params)
  (if (< (length params) 1)
      ""
      (let loop ((key (car params))
		 (val (cadr params))
		 (tail (cddr params))
		 (result '()))
	(let ((newresult (cons (string-append (s:any->string key) "=" (s:any->string val))
			       result)))
	  (if (< (length tail) 1) ;; true if done
	      (string-intersperse newresult "&")
	      (loop (car tail)(cadr tail)(cddr tail) newresult))))))

(define (session:link-to self page params)
  (let* ((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))
		       (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 (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  (sdat-get-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)
    (lambda () 
      (apply print msg))))

(define (session:get-param self key)
  ;; (session:log s:session "params=" (slot-ref s:session '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 (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>)
		(formdat:get formdat key)
		(begin
		  (session:log self "ERROR: formdat: " formdat " is not of class <formdat>")
		  #f))
	    (session:log self "ERROR: bad key " key)))))

(define (session:run-actions self)
  (let* ((action    (session:get-param self 'action))
	 (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)) 
	      (err:log "Action should be of form: module.action")
	      (let* ((targ-page   (car action-lst))
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
		    ((eval (string->symbol proc-name)) targ-action) ;; unsafe execution
		    (condition-case ((eval (string->symbol proc-name)) targ-action)
				    ((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 <session>) page)
  (session:log self "Checking for page: " page)
  (not (member page (slot-ref self 'seen-pages))))

(define-method (session:set-called! (self <session>) page)
  (slot-set! self 'seen-pages (cons page (slot-ref self 'seen-pages))))

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

(define-method (session:alt-out (self <session>))
  (let ((dat (slot-ref self 'alt-page-dat)))
    ;; (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 "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))))







|

|

|
|





|
|



|








738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
		    ((eval (string->symbol proc-name)) targ-action) ;; unsafe execution
		    (condition-case ((eval (string->symbol proc-name)) targ-action)
				    ((exn file) (s:log "file error"))
				    ((exn i/o)  (s:log "i/o error"))
				    ((exn )     (s:log "Action not implemented: " proc-name " action: " targ-action))
				    (var ()     (s:log "Unknown Error"))))))))))

(define (session:never-called-page? self page)
  (session:log self "Checking for page: " page)
  (not (member page (sdat-get-seen-pages self))))

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

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

(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: " (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))))

Modified setup.scm from [9d72fef321] to [b36f45d459].

1
2
3
4
5
6
7
8
9



10
11

12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
;; Copyright 2007-2008, 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.




;; 
(define s:session (make <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))

(define (s:local-set! k v)
  (hash-table-set! s:local-vars k v))

(define (s:local-get k)
  (hash-table-ref/default s:local-vars k #f))

(session:setup s:session)

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

(session:get-vars s:session)

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

;; Usage: (s:get-err s:big)
(define (s:get-err wrapperfunc)
  (let ((errmsg (slot-ref s:session 'curr-err)))
    (if errmsg ((if wrapperfunc
                    wrapperfunc
                    s:strong) errmsg) '())))

(define (s:current-page)
  (slot-ref s:session 'page))

(define (s:delete-session)
  (session:delete-session s:session (slot-ref s:session 'session-key)))

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

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

(define (s:get-param key)
  (session:get-param s:session key))
|








>
>
>

|
>



















|



|





|


|



|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
;; 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-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))

(define (s:local-set! k v)
  (hash-table-set! s:local-vars k v))

(define (s:local-get k)
  (hash-table-ref/default s:local-vars k #f))

(session:setup s:session)

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

(session:get-vars s:session)

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

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

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

(define (s:delete-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 #f)
      (session:call s:session page (car partsl))))

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

(define (s:get-param key)
  (session:get-param s:session key))
91
92
93
94
95
96
97
98
99
100
101
102
(define (s:load-model model)
  (session:load-model s:session model))

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

(define (s:db)
  (slot-ref s:session 'conn))

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








|




95
96
97
98
99
100
101
102
103
104
105
106
(define (s:load-model model)
  (session:load-model s:session model))

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

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

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

Modified sqlite3.scm from [67e8c1f054] to [935dbe7787].

1
2
3
4
5
6
7
8
;; Copyright 2007-2008, 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.
|







1
2
3
4
5
6
7
8
;; 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.

Modified sqltbl.scm from [b05f4ba4b6] to [39c7ffe769].

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20






















21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
;; Copyright 2007-2008, 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 <sqltbl> ()
  (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 <sqltbl>) 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 <sqltbl>))
  (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
        (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)
          new-curr-row))))

;; run the query and fill the rows list 
(define-method (sqltbl:run-query (self <sqltbl>) . params)
  (let* ((query  (slot-ref self 'query))
         (fields (slot-ref self 'fields))
         (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)
				actual-query)
                 (slot-set! self 'query-params params)
                 (slot-set! self 'num-rows (length result))
                 (sqltbl:setup-fields self)  ;; update the fields lookup hash
                 (reverse result))))
    (slot-set! self 'rows rows)
    (if (not (null? rows))
        (slot-set! self 'curr-row (car rows)))
    (slot-set! self 'curr-row-ptr 0)
    rows))

(define-method (sqltbl:setup-fields (self <sqltbl>))
  (let ((fields-hash (slot-ref self 'fields-hash))
        (fields-list (slot-ref self 'fields)))
    (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 <sqltbl>) field)
  (let ((curr-row  (slot-ref self 'curr-row))
        (field-num (hash-table-ref/default (slot-ref self 'fields-hash) field #f)))
    (if field-num 
        (vector-ref curr-row field-num)
        #f))) ;; not found -> #f

(define-method (sqltbl:vector->hash (self <sqltbl>) vec)
  (let ((h      (make-hash-table))
        (fields (slot-ref self 'fields)))
    (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 <sqltbl>) proc)
  (map (lambda (row)
         (proc (sqltbl:vector->hash self row))) (slot-ref self 'rows)))
   
|




<
<
|

|
|
|
|
|
|
|
|
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

|
<
|
|
|
|
|
|
|

|
|
|
|
|

|
|



|
|
|





|

|
|


|

|
|


|
|
|








|
|
|




|

|







|

|

1
2
3
4
5


6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42

43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
;; Copyright 2007-2011, Matthew Welland. Kiatoa.com All rights reserved.
;; 

;; DON'T USE THIS!!!! It was a bad idea :-(



;; (require-extension tinyclos)

;; (define-class <sqltbl> ()
;;   (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)))
          (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 (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)))
                                    (sqltbl:tbl-get-conn self)
				actual-query)
                 (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))))
    (sqltbl:tbl-set-rows! self rows)
    (if (not (null? rows))
        (sqltbl:tbl-set-curr-row! self (car rows)))
    (sqltbl:tbl-set-curr-row-ptr! self 0)
    rows))

(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 (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 (sqltbl:vector->hash self vec)
  (let ((h      (make-hash-table))
        (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 (sqltbl:map self proc)
  (map (lambda (row)
         (proc (sqltbl:vector->hash self row))) (sqltbl:tbl-get-rows self)))
   

Modified stml.config.template from [a7763dfd6d] to [007967e3ce].

1
2
3
4
5
6
7
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")
|
|
|
|
|
|
|
|
1
2
3
4
5
6
7
8
'(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")

Modified stml.scm from [790f2122c1] to [d231bbdbe7].

1
2
3
4
5
6
7
8
9
10
11



12
13
14
15
16
17
18
;; Copyright 2007-2008, 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.

;; stml is a list of html strings




;; extract various tokens from the parameter list
;;   'key val => put in the params list
;;   strings  => maintain order and add to the datalist <<== IMPORTANT
(define (s:extract inlst)
  (if (null? inlst) inlst
      (let loop ((data '())
                 (params '())
|










>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
;; 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.

;; 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
      (let loop ((data '())
                 (params '())

Modified stmlrun.scm from [0494197193] to [c4bf2d3a15].

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18

19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
#!/usr/local/bin/csi -q

;; Copyright 2007-2008, 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))

(use 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"))
;; (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))))

(if (eq? (slot-ref s:session 'page-type) 'html) ;; default is html. 
    (session:cgi-out s:session)
    (session:alt-out s:session))

(session:save-vars s:session)

(session:close s:session)



|









|

|


|
>
|
|
|
<
|
|
|
|
<

|
|

|






|
|
|

|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22

23
24
25
26

27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
#!/usr/local/bin/csi -q

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

(require-library dbi)

(include "requirements.scm")
(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)

(sdat-set-pagedat! s:session
           (append (sdat-get-pagedat s:session)
                   (s:call (sdat-get-toppage s:session))))

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

(session:close s:session)

Modified sugar.scm from [915b31470a] to [08f3dbeadf].

1
2
3
4
5
6
7
8
;; Copyright 2007-2008, 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.
|







1
2
3
4
5
6
7
8
;; 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.

Added test.scm version [62a996e095].













































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
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 version [0f6611f558].





















>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
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"))))

Modified tests/test.scm from [855998c61d] to [9cca07365b].

1
2
3
4
5
6
7
8
9
10
11
12
13





14

15
16
17
18
19
20
21
#!/usr/local/bin/csi -q 

;; Copyright 2007-2008, 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.

(use test md5 dbi)






(load "./requirements.scm")

(load "./misc-stml.scm")
(load "./formdat.scm")
(load "./stml.scm")
(load "./session.scm")
(load "./sqltbl.scm")
(load "./html-filter.scm")
(load "./keystore.scm")











|

>
>
>
>
>

>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
#!/usr/local/bin/csi -q 

;; Copyright 2007-2008, 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.

(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")
(load "./html-filter.scm")
(load "./keystore.scm")
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87

;; (test "Session var del"                    #f   (s:session-var-get "nick"))

;; test person

(load "./tests/models/test.scm")

(print "Session key is " (slot-ref s:session 'session-key))

(test "Delete session" #t (s:delete-session))

(let ((fh (open-input-pipe "ls ./tests/pages/*/control.scm")))
  (let loop ((l (read-line fh)))
    (if (not (eof-object? l))
        (begin







|







79
80
81
82
83
84
85
86
87
88
89
90
91
92
93

;; (test "Session var del"                    #f   (s:session-var-get "nick"))

;; test person

(load "./tests/models/test.scm")

(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)))
    (if (not (eof-object? l))
        (begin
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126

(test "misc:non-zero-string \"\"" #f (misc:non-zero-string ""))
(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 <formdat>" #t (let ((f (make <formdat>)))
			    (set! form f)
			    #t))
(test "formdat: set!/get" "Yep!" (begin
				   (formdat:set! form "blah" "Yep!")
				   (formdat:get  form "blah")))

(test "s:string->pgint"   123 (s:any->pgint "123"))







|







118
119
120
121
122
123
124
125
126
127
128
129
130
131
132

(test "misc:non-zero-string \"\"" #f (misc:non-zero-string ""))
(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 <formdat>" #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")))

(test "s:string->pgint"   123 (s:any->pgint "123"))