Overview
Comment:Add filtering to s:get-input. Switch to dbi.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: e78a65d865d2cafdcc7746daa3b2b1c02de345ae
User & Date: matt on 2016-09-19 05:55:31
Other Links: manifest | tags
Context
2016-09-19
06:05
Oops. missed setup.scm check-in: 4b5ced8c71 user: matt tags: trunk
05:55
Add filtering to s:get-input. Switch to dbi. check-in: e78a65d865 user: matt tags: trunk
2016-07-28
06:46
emit limited debug info to the user if not in debug mode. Give name of log file check-in: bd6f7bf73b user: matt tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Modified misc-stml.scm from [9494e07667] to [1a4eccad68].

︙︙
9
10
11
12
13
14
15


16
17
18
19
20
21
22


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








>
>








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


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

(declare (unit misc-stml))
(use regex)
(use dbi)
(import (prefix dbi dbi:))

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

Modified session.scm from [b28c169b67] to [cfa085cc41]. 

1
2
3
4
5
6
7
8
9
10
11


12
13
14
15
16
17
18

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


(require-extension regex)
(declare (uses cookie))

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












|
>
>








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

;; 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 dbi)
(import (prefix dbi dbi:))
(require-extension regex)
(declare (uses cookie))

;; sessions table
;; id session_id session_key
;; create table sessions (id serial not null,session-key text);
︙︙
719
720
721
722
723
724
725






726






727
728
729
730
731
732
733
734

735






736
737
738
739
740
741
742


(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 (and (vector? formdat)(eq? (vector-length formdat) 1)(hash-table? (vector-ref formdat 0)))
		(formdat:get formdat key)
		(begin
		  (session:log self "ERROR: formdat: " formdat " is not of class <formdat>")
		  #f))

	    (session:log self "ERROR: bad key " key)))))







;; This one will get the first value found regardless of form
(define (session:get-input-keys self)
  (let* ((formdat (sdat-get-formdat self)))
    (if (not formdat) #f
	(if (and (vector? formdat)(eq? (vector-length formdat) 1)(hash-table? (vector-ref formdat 0)))
	    (formdat:keys formdat)








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








721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
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


(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
;; param: (dtype [tag1 tag2 ...])
;; dtype:
;;    'raw     : do no conversion
;;    'number  : convert to number, return #f if fails
;;    'escaped : use html-escape to protect the input
;;
(define (session:get-input self key params)
  (let* ((dtype    (if (null? params)
		       'escaped
		       (car params)))
	 (tags    (if (null? params)
		      '()
		      (cdr params)))
	 (formdat (sdat-get-formdat self))
	 (res     (if (not formdat) #f
		      (if (or (string? key)(number? key)(symbol? key))
			  (if (and (vector? formdat)(eq? (vector-length formdat) 1)(hash-table? (vector-ref formdat 0)))
			      (formdat:get formdat key)
			      (begin
				(session:log self "ERROR: formdat: " formdat " is not of class <formdat>")
				#f))
			  (begin
			    (session:log self "ERROR: bad key " key)
			    #f)))))
    (case dtype
      ((raw)     res)
      ((number)  (if (string? res)(string->number res) #f))
      ((escaped) (s:html-filter res tags)) 
      (else      (s:html-filter res '())))))

;; This one will get the first value found regardless of form
(define (session:get-input-keys self)
  (let* ((formdat (sdat-get-formdat self)))
    (if (not formdat) #f
	(if (and (vector? formdat)(eq? (vector-length formdat) 1)(hash-table? (vector-ref formdat 0)))
	    (formdat:keys formdat)
︙︙

Modified stmlcommon.scm from [b8b7585622] to [c37d1e8589].

︙︙
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87

			 (print (car var) "\t" (cdr var)))
		       (get-environment-variables))))
	 ;; return something useful to the user
	 (print "Content-type: text/html")
	 (print "")
	 (print "<html> <head> <title>EXCEPTION</title> </head> <body>")
	 (print "<h1>CRASH!</h1>")
	 (print "   Please notify support at " (sdat-get-domain s:session) " that the error log is stmlcrash-" (current-process-id) ".log</b> <br>")
	 ;; (print "<pre>")
	 ;; ;; (print "   EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
	 ;; ;; (print-error-message exn)
	 ;; ;; (print-call-chain)
	 ;; (print "</pre>")
	 ;; (print "<table>")
	 ;; (for-each (lambda (var)








|








73
74
75
76
77
78
79
80
81
82
83
84
85
86
87

			 (print (car var) "\t" (cdr var)))
		       (get-environment-variables))))
	 ;; return something useful to the user
	 (print "Content-type: text/html")
	 (print "")
	 (print "<html> <head> <title>EXCEPTION</title> </head> <body>")
	 (print "<h1>CRASH!</h1>")
	 (print "   Please notify support at " (sdat-get-domain s:session) " that the error log is stml-crash-" (current-process-id) ".log</b> <br>")
	 ;; (print "<pre>")
	 ;; ;; (print "   EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
	 ;; ;; (print-error-message exn)
	 ;; ;; (print-call-chain)
	 ;; (print "</pre>")
	 ;; (print "<table>")
	 ;; (for-each (lambda (var)
︙︙