;; 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))
(module stml2
*
(import chicken scheme data-structures extras srfi-13 ports posix srfi-69 files srfi-1)
(import cookie)
(use (prefix dbi dbi:) (prefix crypt c:) typed-records)
;; (declare (uses misc-stml))
(use regex)
;; The (usually global) sdat contains everything about the session
;;
(defstruct sdat
;; database
(dbtype 'pg)
(dbinit #f)
(conn #f)
;; page info
(page "index")
(page-type 'html)
(toppage "index")
(curr-page "index")
(content-type "Content-type: text/html; charset=iso-8859-1\n\n")
;; forms and variables
(formdat #f)
(params '())
(path-params '())
(session-key #f)
(pagedat '())
(alt-page-dat #f)
(session-cookie #f)
(pagevars (make-hash-table))
(pagevars-before (make-hash-table))
(sessionvars (make-hash-table))
(sessionvars-before (make-hash-table))
(globalvars (make-hash-table))
(globalvars-before (make-hash-table))
;; ports and log file
(curr-err #f)
(log-port (current-error-port))
(logfile "/tmp/stml.log")
(seen-pages '())
(page-dir-style 'flat)
(debug-mode #f)
(session-id #f)
(request-method #f)
(domain "localhost")
(twikidir #f)
(script #f)
(force-ssl #f)
(shared-hash (make-hash-table))
;; paths
(sroot "./")
(models #f)
(views #f)
)
(define (sdat-set-if session configdat var settor)
(let ((val (s:find-param var configdat)))
(if val (settor session val))))
(define (session:initialize session #!optional (configf #f))
;; (let* ((rawconfigdat (session:read-config session configf))
;; (configdat (if rawconfigdat (eval rawconfigdat) '())))
;; (sdat-set-if session configdat 'sroot sdat-root-set!)
;; (sdat-set-if session configdat 'logfile sdat-logfile-set!)
;; (sdat-set-if session configdat 'dbtype sdat-dbtype-set!)
;; (sdat-set-if session configdat 'dbinit sdat-dbinit-set!)
;; (sdat-set-if session configdat 'domain sdat-domain-set!)
;; (sdat-set-if session configdat 'twikidir sdat-twikidir-set!)
;; (sdat-set-if session configdat 'page-dir-style sdat-page-set!)
;; (sdat-set-if session configdat 'sroot sdat-root-set!)
;; (sdat-set-if session configdat 'sroot sdat-root-set!)
;; (sdat-set-if session configdat 'sroot sdat-root-set!)
;; following are set always from config
;; (sdat-page-dir-style-set! session (s:find-param 'page-dir-style configdat))
(let* ((rawconfigdat (session:read-config session configf))
(configdat (if rawconfigdat (eval rawconfigdat) '()))
(sroot (s:find-param 'sroot configdat))
(models (s:find-param 'models configdat))
(views (s:find-param 'views configdat))
(logfile (s:find-param 'logfile configdat))
(dbtype (s:find-param 'dbtype configdat))
(dbinit (s:find-param 'dbinit configdat))
(domain (s:find-param 'domain configdat))
(twikidir (s:find-param 'twikidir configdat))
(page-dir (s:find-param 'page-dir-style configdat))
(debugmode (or (s:find-param 'debug-mode configdat)(s:find-param 'debugmode configdat)))
(script (s:find-param 'script configdat))
(force-ssl (s:find-param 'force-ssl configdat)))
(if sroot (sdat-sroot-set! session sroot))
(if models (sdat-models-set! session models))
(if views (sdat-views-set! session views))
(if logfile (sdat-logfile-set! session logfile))
(if dbtype (sdat-dbtype-set! session dbtype))
(if dbinit (sdat-dbinit-set! session dbinit))
(if domain (sdat-domain-set! session domain))
(if twikidir (sdat-twikidir-set! session twikidir))
(if debugmode (sdat-debug-mode-set! session debugmode))
(if script (sdat-script-set! session script))
(if force-ssl (sdat-force-ssl-set! session force-ssl))
(sdat-page-dir-style-set! session page-dir)
;; (print "configdat: ")(pp configdat)
(if debugmode
(session:log session "sroot: " sroot " logfile: " logfile " dbtype: " dbtype
" dbinit: " dbinit " domain: " domain " page-dir-style: " page-dir))
))
;; extract various tokens from the parameter list
;; 'key val => put in the params list
;; strings => maintain order and add to the datalist <<== IMPORTANT
(define (s:extract inlst)
(if (null? inlst) inlst
(let loop ((data '())
(params '())
(head (car inlst))
(tail (cdr inlst)))
;; (print "head=" head " tail=" tail)
(cond
((null? tail)
(if (symbol? head) ;; the last item is a param - borked
(s:log "ERROR: param with no value"))
(list (append data (list (s:any->string head))) params))
((or (string? head)(list? head)(number? head))
(loop (append data (list (s:any->string head))) params (car tail) (cdr tail)))
((symbol? head)
(let ((new-params (cons (list head (car tail)) params))
(new-tail (cdr tail)))
(if (null? new-tail) ;; we are done, no more params etc.
(list data new-params)
(loop data new-params (car new-tail)(cdr new-tail)))))
(else
(s:log "WARNING: Malformed input, you have broken stml, remember that all stml calls should return a result (null list or empty string is ok):\n head=" head
"\n tail=" tail
"\n inlst=" inlst
"\n params=" params)
(if (null? tail)
(list data params)
(loop data params (car tail)(cdr tail))))))))
;; most tags can be handled by this routine
(define (s:common-tag tagname args)
(let* ((inputs (s:extract args))
(data (car inputs))
(params (s:process-params (cadr inputs))))
(list (conc "<" tagname params ">")
data
(conc "</" tagname ">"))))
;; Suggestion: order these alphabetically
(define (s:a . args) (s:common-tag "A" args))
(define (s:b . args) (s:common-tag "B" args))
(define (s:u . args) (s:common-tag "U" args))
(define (s:big . args) (s:common-tag "BIG" args))
(define (s:body . args) (s:common-tag "BODY" args))
(define (s:button . args) (s:common-tag "BUTTON" args))
(define (s:center . args) (s:common-tag "CENTER" args))
(define (s:code . args) (s:common-tag "CODE" args))
(define (s:div . args) (s:common-tag "DIV" args))
(define (s:h1 . args) (s:common-tag "H1" args))
(define (s:h2 . args) (s:common-tag "H2" args))
(define (s:h3 . args) (s:common-tag "H3" args))
(define (s:h4 . args) (s:common-tag "H4" args))
(define (s:h5 . args) (s:common-tag "H5" args))
(define (s:head . args) (s:common-tag "HEAD" args))
(define (s:html . args) (s:common-tag "HTML" args))
(define (s:i . args) (s:common-tag "I" args))
(define (s:img . args) (s:common-tag "IMG" args))
(define (s:input . args) (s:common-tag "INPUT" args))
(define (s:output . args) (s:common-tag "OUTPUT" args))
(define (s:link . args) (s:common-tag "LINK" args))
(define (s:p . args) (s:common-tag "P" args))
(define (s:strong . args) (s:common-tag "STRONG" args))
(define (s:table . args) (s:common-tag "TABLE" args))
(define (s:tbody . args) (s:common-tag "TBODY" args))
(define (s:thead . args) (s:common-tag "THEAD" args))
(define (s:th . args) (s:common-tag "TH" args))
(define (s:td . args) (s:common-tag "TD" args))
(define (s:title . args) (s:common-tag "TITLE" args))
(define (s:tr . args) (s:common-tag "TR" args))
(define (s:small . args) (s:common-tag "SMALL" args))
(define (s:quote . args) (s:common-tag "QUOTE" args))
(define (s:hr . args) (s:common-tag "HR" args))
(define (s:li . args) (s:common-tag "LI" args))
(define (s:ul . args) (s:common-tag "UL" args))
(define (s:ol . args) (s:common-tag "OL" args))
(define (s:dl . args) (s:common-tag "DL" args))
(define (s:dt . args) (s:common-tag "DT" args))
(define (s:dd . args) (s:common-tag "DD" args))
(define (s:pre . args) (s:common-tag "PRE" args))
(define (s:span . args) (s:common-tag "SPAN" args))
(define (s:label . args) (s:common-tag "LABEL" args))
(define (s:script . args) (s:common-tag "SCRIPT" args))
(define (s:dblquote . args)
(let* ((inputs (s:extract args))
(data (caar inputs))
(params (s:process-params (cadr inputs))))
(conc """ data """)))
(define (s:br . args) "<BR>") ;; THIS MAY NOT WORK!!!! BR CAN (MISTAKENLY) GET PARAM TEXT
;; (define (s:br . args) (s:common-tag "BR" args))
(define (s:font . args) (s:common-tag "FONT" args))
(define (s:err-font . args)
(s:b (s:font 'color "red" args)))
(define (s:comment . args)
(let* ((inputs (s:extract args))
(data (car inputs))
(params (s:process-params (cadr inputs))))
(list "<!--" data "-->")))
(define (s:null . args) ;; nop
(let* ((inputs (s:extract args))
(data (car inputs))
(params (s:process-params (cadr inputs))))
(list data)))
;; puts a nice box around a chunk of stuff
(define (s:fieldset legend . args)
(list "<FIELDSET><LEGEND>" legend "</LEGEND>" args "</FIELDSET>"))
;; given a string return the string if it is non-white space or otherwise
(define (s:nbsp str)
(if (string-match "^\\s*$" str)
" "
str))
;; USE 'page_override to override a linkto page from a button
(define (s:form . args)
;; create a link for calling back into the current page and calling a specified
;; function
(let* ((action (let ((v (s:find-param 'action args)))
(if v v "default")))
(id (let ((i (s:find-param 'id args)))
(if i i #f)))
(page (let ((p (sdat-page s:session)))
(if p p "home")))
;; (link (session:link-to s:session page (if id
;; (list 'action action 'id id)
;; (list 'action action)))))
(link (if (string=? (substring action 0 5) "http:") ;; if first part of string is http:
action
(session:link-to s:session
page
(if id
(list 'action action 'id id)
(list 'action action))))))
;; (script (slot-ref s:session 'script))
;; (action-str (string-append script "/" page "?action=" action)))
(s:common-tag "FORM" (append (s:remove-param-matching (s:remove-param-matching args 'action) 'id)
(list 'action link)))))
;; look up the variable name (via the 'name tag) then inject the value from the session var
;; replacing the 'value value if it is already there, adding it if it is not.
(define (s:preserve tag args)
(let* ((var-name (s:find-param 'name args)) ;; name='varname'
(value (let ((v (s:get var-name)))
(if v v #f)))
(newargs (append (s:remove-param-matching args 'value) (if value (list 'value value) '()))))
(s:common-tag tag newargs)))
(define (s:input-preserve . args)
(s:preserve "INPUT" args))
;; text areas are done a little differently. The value is stored between the tags <textarea ...>the value goes here</textarea>
(define (s:textarea-preserve . args)
(let* ((var-name (s:find-param 'name args))
(value (let ((v (s:get var-name)))
(if v v #f))))
(s:common-tag "TEXTAREA" (if value (cons value args) args))))
(define (s:option dat)
(let ((len (length dat)))
(cond
((eq? len 1)
(let ((item (car dat)))
(s:option (list item item item))))
((eq? len 2)
(s:option (append dat (list (car dat)))))
(else
(let ((label (car dat))
(value (cadr dat))
(dispval (caddr dat))
(selected (if (> len 3)(cadddr dat) #f)))
(list (conc "<OPTION "
(if selected " selected " "")
"label=\"" label
"\" value=\"" value
"\">" dispval "</OPTION>")))))))
;; call only with (label (label value dispval [#t]) ...)
;; NB// sadly this block is redundantly almost identical to the s:select
;; fix that later ...
(define (s:optgroup dat)
(let ((label (car dat))
(rem (cdr dat)))
(if (null? rem)
(s:common-tag "OPTGROUP" `('label ,label))
(let loop ((hed (car rem))
(tal (cdr rem))
(res (list (conc "<OPTGROUP label=" label))))
;; (print "hed: " hed " tal: " tal " res: " res)
(let ((new (append res (list (if (list? (cadr hed))
(s:optgroup hed)
(s:option hed))))))
(if (null? tal)
(append new (list "</OPTGROUP>"))
(loop (car tal)(cdr tal) new)))))))
;; items is a hierarchial alist
;; ( (label1 value1 dispval1 #t) ;; <== this one is selected
;; (label2 (label3 value2 dispval2)
;; (label4 value3 dispval3)))
;;
;; required arg is 'name
(define (s:select items . args)
(if (null? items)
(s:common-tag "SELECT" args)
(let loop ((hed (car items))
(tal (cdr items))
(res '()))
;; (print "hed: " hed " tal: " tal " res: " res)
(let ((new (append res (list (if (and (> (length hed) 1)
(list? (cadr hed)))
(s:optgroup hed)
(s:option hed))))))
(if (null? tal)
(s:common-tag "SELECT" (cons new args))
(loop (car tal)(cdr tal) new))))))
(define (s:color . args)
"#00ff00")
(define (s:print indent inlst)
(map (lambda (x)
(cond
((or (string? x)(symbol? x))
(print (conc (make-string (* indent 2) #\ ) (s:any->string x))))
((list? x)
(s:print (+ indent 1) x))
(else
;; (print "ERROR: Bad input 01") ;; why do anything with junk?
)))
inlst))
;; Moved to misc-stml
;;
#;(define (s:cgi-out inlst)
(s:output (current-output-port) inlst))
#;(define (s:output port inlst)
(map (lambda (x)
(cond
((string? x) (print x)) ;; (print x))
((symbol? x) (print x)) ;; (print x))
((list? x) (s:output port x))
(else ""
;; (print "ERROR: Bad input 02") ;; why do anything? don't output junk.
)))
inlst))
; (if (> (length inlst) 2)
; (print)))
#;(define (s:output-new port inlst)
(with-output-to-port port
(lambda ()
(map (lambda (x)
(cond
((string? x) (print x))
((symbol? x) (print x))
((list? x) (s:output port x))
(else
;; (print "ERROR: Bad input 03")
)))
inlst))))
;;======================================================================
;; Not sure where these should go
;;======================================================================
;; (include "requirements.scm"), dbi has autoload, should not need this any more.
;;======================================================================
;; setup - convience calls to functions wrapped with a global s:session
;;======================================================================
;; macros in sugar don't work, have to load in all files or use compiled mode?
;;
;; (include "sugar.scm")
;; use this for getting data from page to page when scope and evals
;; get in the way
;; save data for use in the page generation here. Does NOT persist across page reads.
(define *page-data* (make-hash-table))
(define (s:lset! var val)
(hash-table-set! *page-data* var val))
(define (s:lget var . default)
(hash-table-ref/default *page-data* var (if (null? default)
#f
(car default))))
;; to obscure and indirect database ids use one time keys
;;
;; (s:get-key 'n 1) => "n99e1882" n=number 99e is the week number since 1970, remainder is random
;; (s:key->val "n1882") => 1
;;
;; first letter is a type: n=number, s=string, b=boolean
(define (s:get-key key-type val)
(let ((mkrandstr (lambda (innum)(number->string (random innum) 16)))
(week (number->string (quotient (current-seconds) (* 7 24 60 60)) 16)))
(let loop ((siz 1000)
(key (conc key-type week (mkrandstr 100)))
(num 0))
(if (s:session-var-get key) ;; have a collision
(loop (cond ;; in the unlikey event we have trouble getting a new var, keep increasing the size of the number
((< num 50) 100)
((< num 100) 1000)
((< num 200) 10000)
((< num 300) 100000)
((< num 400) 1000000) ;; can't imagine needing to get here. remember that this is for a single user
(else 100000000))
(conc key-type (mkrandstr siz))
(+ num 1))
(begin
(s:session-var-set! key val)
key)))))
;; given a key Xnnnn, look up the stored value and convert it appropriately, then
;; destroy the stored session var
;;
(define (s:key->val key)
(let ((val (s:session-var-get key))
(typ (string->symbol (substring key 0 1))))
(if val
(begin
(s:session-var-del! key)
;; we take this opportunity to clean up old keyed session vars
;; if more than 100 vars, remove all that are over 1-2 weeks old
;(s:cleanup-session-vars)
(case typ
((n)(string->number val))
((s) val)
(else val)))
val)))
;; clean up session vars
;;
(define (s:cleanup-session-vars)
(let* ((session-vars (hash-table-keys (s:session-get-sessionvars)))
(week-num (quotient (current-seconds) (* 7 24 60 60)))
(week (number->string week-num 16)))
(if (> (length session-vars) 100)
(for-each
(lambda (var)
(if (> (string-length var) 5) ;; can't have keyed values with keys less than 5 characters long
(let ((var-week (string->number (substring var 1 4) 16)))
(if (and var-week
(>= (- week-num var-week) 2))
(s:session-var-del! var)))))
session-vars))))
;; inputs
;;
;; 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 (s:get-input key . params)
(session:get-input s:session key params))
(define (s:get-input-keys)
(session:get-input-keys s:session))
;; get-input else, get-param else #f
;;
(define (s:get-inp key . params)
(or (apply s:get-input key params)
(apply s:get-param key params)))
(define (s:load-model model)
(session:load-model s:session model))
(define (s:model-path)
(session:model-path s:session))
;; share data between pages calls. NOTE: This is not persistent
;; between cgi calls. Use sessionvars for that.
;;
(define (s:shared-hash)
(sdat-shared-hash s:session))
(define (s:shared-set! key val)
(hash-table-set! (sdat-shared-hash s:session) key val))
;; What to return when no value for key?
;;
(define (s:shared-get key)
(hash-table-ref/default (sdat-shared-hash s:session) key #f))
;; http://foo.bar.com/pagename/p1/p2 => '("p1" "p2")
;; #### DEPRECATED ####
(define (s:get-page-params)
(sdat-path-params s:session))
(define (s:get-path-params)
(sdat-path-params s:session))
(define (s:db)
(sdat-conn s:session))
;;======================================================================
;; cgi and session stuff
;;======================================================================
;;(declare (uses cookie))
;;(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))
;; 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))
(if (eq? head field-name) fnum
(if (null? tail) #f
(loop (car tail)(cdr tail)(+ fnum 1))))))
(define (s:fields->string lst)
(string-join (map symbol->string lst) ","))
(define (s:vector-get-field vec field field-list)
(vector-ref vec (s:get-fieldnum field-list field)))
;;======================================================================
;;
;;======================================================================
;; moved to misc-stml
;;
#;(define (err:log . msg)
(with-output-to-port (current-error-port) ;; (slot-ref self 'logpt)
(lambda ()
(apply print msg))))
(define (s:tidy-url url)
(if url
(let ((r1 (regexp "^http:\\/\\/"))
(r2 (regexp "^[ \\t]*$"))) ;; blank
(if (string-match r1 url) url
(if (string-match r2 url) #f ;; convert a blank to #f
(conc "http://" url))))
url))
(define (s:lazy->num num)
(if (number? num) num
(if (string->number num) (string->number num)
(if num 1 0)))) ;; wierd eh! yep, #f=>0 #t=>1
;;======================================================================
;; D B
;;======================================================================
;; convert values to appropriate strings
;;
#;(define (s:sqlparam-val->string val)
(cond
((list? val)(string-join (map symbol->string val) ",")) ;; (a b c) => a,b,c
((string? val)(conc "'" (dbi:escape-string val) "'"))
((number? val)(number->string val))
((symbol? val)(dbi:escape-string (symbol->string val)))
((boolean? val)
(if val "TRUE" "FALSE")) ;; should this be "TRUE" or 1?
;; should this be "FALSE" or 0 or NULL?
(else
(err:log "sqlparam: unknown type for value: " val)
"")))
;; (sqlparam "INSERT INTO foo(name,age) VALUES(?,?);" "bob" 20)
;; NB// 1. values only!!
;; 2. terminating semicolon required (used as part of logic)
;;
;; a=? 1 (number) => a=1
;; a=? 1 (string) => a='1'
;; a=? #f => a=FALSE
;; a=? a (symbol) => a=a
;;
#;(define (s:sqlparam query . args)
(let* ((query-parts (string-split query "?"))
(num-parts (length query-parts))
(num-args (length args)))
(if (not (= (+ num-args 1) num-parts))
(err:log "ERROR, sqlparam: wrong number of arguments or missing semicolon, " num-args " for query " query)
(if (= num-args 0) query
(let loop ((section (car query-parts))
(tail (cdr query-parts))
(result "")
(arg (car args))
(argtail (cdr args)))
(let* ((valstr (s:sqlparam-val->string arg))
(newresult (conc result section valstr)))
(if (null? argtail) ;; we are done
(conc newresult (car tail))
(loop
(car tail)
(cdr tail)
newresult
(car argtail)
(cdr argtail)))))))))
;;======================================================================
;; M I S C S T R I N G S T U F F
;;======================================================================
(define (s:string-downcase str)
(if (string? str)
(string-translate str "ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyz")
str))
;; (define session:valid-chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789")
#;(define session:valid-chars "abcdefghijklmnopqrstuvwxyz0123456789") ;; cookies are case insensitive.
#;(define session:num-valid-chars (string-length session:valid-chars))
#;(define (session:get-nth-char nth)
(substring session:valid-chars nth (+ nth 1)))
#;(define (session:get-rand-char)
(session:get-nth-char (random session:num-valid-chars)))
#;(define (session:make-rand-string len)
(let loop ((res "")
(n 1))
(if (> n len) res
(loop (string-append res (session:get-rand-char))
(+ n 1)))))
;; maybe replace above make-rand-string with this someday?
;;
#;(define (session:generic-make-rand-string len seed-string)
(let ((num-chars (string-length seed-string)))
(let loop ((res "")
(n 1))
(let ((char-num (random num-chars)))
(if (> n len) res
(loop (string-append res (substring seed-string char-num (+ char-num 1)))
(+ n 1)))))))
;; Rely on crypt egg's default settings being secure enough, accept
;; backwards-compatible OpenSSL crypt passwords too.
;;
(define (s:crypt-passwd pw s)
(c:crypt pw (or s (c:crypt-gensalt))))
(define (s:password-match? password crypted)
(let* ((salt (substring crypted 0 2))
(pcrypted (s:crypt-passwd password salt)))
;; (s:log "INFO: pcrypted=" pcrypted " crypted=" crypted)
(and (string? password)
(string? pcrypted)
(string=? pcrypted crypted))))
;; (read-line (open-input-pipe "echo foo | mkpasswd -S ab -s"))
;; BUG: The regex implements a rule, but what rule? AH! usaztempe, get rid of this? No, this also looks for &key=value ...
(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
"REQUEST URI NOT AVAILABLE!"
(let ((p (open-input-pipe "env")))
(let loop ((l (read-line p))
(res '()))
(if (eof-object? l)
res
(loop (read-line p)(cons (list l "<BR>") res)))))
#t))))
;; moved to misc-stml
;;
;; anything except a list is converted to a string!!!
#;(define (s:any->string val)
(cond
((string? val) val)
((number? val) (number->string val))
((symbol? val) (symbol->string val))
((eq? val #f) "")
((eq? val #t) "TRUE")
((list? val) val)
(else
(let ((ostr (open-output-string)))
(with-output-to-port ostr
(lambda ()
(display val)))
(get-output-string ostr)))))
#;(define (s:any->number val)
(cond
((number? val) val)
((string? val) (string->number val))
((symbol? val) (string->number (symbol->string val)))
(else #f)))
;; NB// this is *illegal* pgint
(define (s:illegal-pgint val)
(cond
((> val 2147483647) 1)
((< val -2147483648) -1)
(else #f)))
(define (s:any->pgint val)
(let ((n (s:any->number val)))
(if n
(if (s:illegal-pgint n)
#f
n)
n)))
;; string is a string and non-zero length
(define (misc:non-zero-string str)
(if (and (string? str)
(> (string-length str) 0))
str
#f))
;;======================================================================
;; 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 '())
(temp ""))
(cond ((equal? head delim)
(set! dest (append dest (list temp)))
(set! temp ""))
((null? head)
(set! dest (append dest (list temp))))
(else (set! temp (string-append temp head)))) ;; end if
(cond ((null? tail)
(set! dest (append dest (list temp))) dest)
(else (loop (make-string 1 (car tail)) (cdr tail) dest temp))))))
;; allowed-tags is a list of tags as symbols:
;; '(a b center p a)
;; parsing is simplistic and the response conservative
;; if a < is found without the tag and closing > then
;; the < or > is replaced with < or > without
;; even trying hard to figure out if there is a legit tag
;; buried in the text somewhere.
;; a list of strings is returned.
;;
;; NOTES
;; 1. case is important in the allowed-tags list!
;; 2. only "solid" tags are supported i.e. <a href="foo"> will not work?
;;
;; (s:cgi-out (eval (s:output (s:html-filter "hello<b>goodbye</b><b> eh" '(a b i))))
;; strategy
;; 1. convert \n to <linefeed>
;; 2. Split on "<"
;; 3. Split on ">"
;; 4. Fix
(define (s:html-filter input-text allowed-tags)
(let* ((toks (s:str->toks input-text))
(tmp (s:toks->stml '(s:null) #f toks allowed-tags))
(res (car tmp))
(nxttag (cadr tmp))
(rem (caddr tmp)))
res))
(define (s:html-filter->string input-text allowed-tags)
(let ((ostr (open-output-string)))
;;; (s:output-new ostr (s:html-filter input-text allowed-tags))
(s:output-new ostr (car (eval (s:html-filter input-text allowed-tags))))
(string-chomp (get-output-string ostr)))) ;; don't need the linefeed, could stop adding it ...
;; (if (null? rem)
;; res '())
;; (s:toks->stml (if (list? res) res '()) #f rem allowed-tags))))
(define (s:str->toks str)
(apply append (map (lambda (tok)
(intersperse (s:split-string tok ">") ">"))
(intersperse (s:split-string str "<") "<"))))
(define (s:tag->stml tag)
(string->symbol (string-append "s:" (symbol->string tag))))
(define (s:toks->stml res tag rem allowed)
;; (print "tag: " tag " rem: " rem)
(if (null? rem)
(list (append res (if tag
(list (s:tag->stml tag))
'())) #f '() allowed) ;; the case of a lone tag
;; handle a starting tag
(let* ((tmp (s:upto-tag rem allowed))
(txt (car tmp)) ;; this txt goes with tag!!!
(nexttag (cadr tmp)) ;; this is the NEXT DAMN tag!
(begin-tag (caddr tmp))
(newrem (cadddr tmp)))
;; (print "txt: " txt "\nnexttag: " nexttag "\nbegin-tag: " begin-tag "\nnewrem: " newrem "\nres: " res "\n")
(if begin-tag ;; nest the following stuff
(let* ((childdat (s:toks->stml '() nexttag newrem allowed))
(child (car childdat))
(newtag (cadr childdat))
(newrem2 (caddr childdat))
(allowed (cadddr childdat))) ;; ya, it shouldn't have changed
(if tag
(s:toks->stml (append res (list (append (list (s:tag->stml tag)) child (list txt))))
newtag newrem2 allowed)
(s:toks->stml (append res (list txt) child)
newtag newrem2 allowed)))
;; it must have been an end tag
(list (append res (list
(if tag
(list (s:tag->stml tag) txt)
txt)))
#f
newrem
allowed)))))
;; "<" "b" ">" => "<b>"
;; "<"
;; (define (s:rebuild-tags input-list)
;; ("blah blah" "<" "b" ">" "more stuff" "<" "i" ">" )
;; => ("blah blah" b #t ( "more stuff" "<" "i" ">" ))
;; ("blah blah" "<" "/b" ">" "more stuff" "<" "i" ">" )
;; => ("blah blah" b #f ( "more stuff" "<" "i" ">" ))
(define (s:upto-tag inlst allowed-tags)
(if (null? inlst) inlst
(let loop ((tok (car inlst))
(tail (cdr inlst))
(prel "")) ;; create a string or a list of string parts?
(if (string=? tok "<") ;; might have a tag
(if (> (length tail) 1) ;; to be a tag, need tag and closing ">"
(let ((tag (car tail))
(end (cadr tail))
(rem (cddr tail)))
(if (string=? end ">") ;; yep, it is probably a tag
(let* ((trim-tag (if (string=? "/" (substring tag 0 1))
(substring tag 1 (string-length tag)) #f))
(tag-sym (string->symbol (if trim-tag trim-tag tag))))
(if (member tag-sym allowed-tags)
;; have a valid tag, rebuild it and return the result
(list prel tag-sym (if trim-tag #f #t) rem)
;; not a valid tag, convert "<" and ">" and add all to prel
(let ((newprel (string-append prel "<" tag ">")))
(if (null? rem)(list newprel #f #f '()) ;; return newprel - add #f #f ???
(loop (car rem)(cdr rem) newprel)))))
;; so, it wasn't a tag
(let ((newprel (string-append prel "<" tag)))
(if (null? tail)
(list newprel #f #f '())
(loop (car rem)(cdr rem) newprel)))))
;; too short to be a tag
(list (apply string-append prel "<" tail) #f #f '()))
(if (null? tail)
;; we're done
(list (string-append prel tok) #f #f '())
(loop (car tail)(cdr tail)(string-append prel tok)))))))
(define (s:divy-up-cgi-str instr)
(map (lambda (x) (string-split x "=")) (string-split instr "&")))
(define (s:decode-str instr)
(let* ((abc (string-substitute "\\+" " " instr #t))
(toks (s:split-string abc "%")))
(if (< (length toks) 2) abc
(let loop ((head (cadr toks))
(tail (cddr toks))
(result (car toks)))
(if (string=? head "")
(if (null? tail)
result
(loop (car tail)(cdr tail) result))
(let* ((key (substring head 0 2))
(rem (substring head 2 (string-length head)))
(num (string->number key 16))
(ch (if (and (number? num)
(exact? num))
(integer->char num)
#f)) ;; this is an error. I will probably regret this some day
(chstr (if ch (make-string 1 ch) ""))
(newres (if ch
(string-append result chstr rem)
(string-append result head))))
;; (print "head: " head " num: " num " ch: |" ch "| chstr: " chstr)
(if (null? tail)
newres
(loop (car tail)(cdr tail) newres))))))))
;; probably a bug:
;;
;; (s:process-cgi-input "=bar")
;; => ((bar ""))
;;
(define (s:process-cgi-input instr)
(map (lambda (xy)
(list (string->symbol (s:decode-str (car xy)))
(if (eq? (length xy) 1)
""
(s:decode-str (cadr xy)))))
(s:divy-up-cgi-str instr)))
;; for testing -- deletme
;; (define blah "post_title=%2B%2B%2B%2B%2B%2B%2B%2B%2B%2B%2Bhello-------------+++++++++++%26%26%26%26%26%26%26%26%26%40%40%40%40%40%40%40%40%40&post_body=%2B%2B%2B%2B%2B%2B%2B%2B%2B%2B%2Bhello-------------+++++++++++%26%26%26%26%26%26%26%26%26%40%40%40%40%40%40%40%40%40%0D%0A%0D%0A%2B%2B%2B%2B%2B%2B%2B%2B%2B%2B%2Bhello-------------+++++++++++%26%26%26%26%26%26%26%26%26%40%40%40%40%40%40%40%40%40%0D%0A%0D%0A%0D%0A%2B%2B%2B%2B%2B%2B%2B%2B%2B%2B%2Bhello-------------+++++++++++%26%26%26%26%26%26%26%26%26%40%40%40%40%40%40%40%40%40&new_post=Submit")
;; (define blah2 "post_title=5%25&post_body=and+10%25&new_post=Submit")
;;======================================================================
;; formdat
;;======================================================================
(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)(vector (make-hash-table)))
(define (formdat:formdat-get-data vec) (vector-ref vec 0))
(define (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)
(cond
((symbol? key) key)
((string? key) (string->symbol key))
(else 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)
(formdat:set! self key val)
(formdat:set! self key (car val)))
(if (null? tail) self ;; we are done
(loop (car tail)(cdr tail))))))))
;; get the header from datstr
(define (formdat:read-header datstr) ;; datstr is an input string port
(let loop ((hs (read-line datstr))
(header '()))
(if (or (eof-object? hs)
(string=? hs ""))
header
(loop (read-line datstr)(append header (list hs))))))
;; get the data up to the next key. if there is no key then return #f
;; return (dat remdat)
(define (formdat:read-dat dat key)
(let ((index (substring-index key dat))) ;; (string-search-positions key dat)))
(if (or (not index)
(null? index)) ;; the key was not found
#f
(let* ((datstr (open-input-string dat))
;; (result (read-string (caar index) datstr))
(result (read-string index datstr))
(remdat (read-string #f datstr)))
(close-input-port datstr)
(list result remdat)))))
;; inp is port to read data from, maxsize is max data allowed to read (total)
(define (formdat:dat->list inp maxsize #!key (debug-port #f))
;; read 1Meg chunks from the input port. If a block is not complete
;; tack on the next 1Meg chunk as needed. Set up so the header is always
;; at the beginning of the chunk
;;-----------------------------29932024411502323332136214973
;;Content-Disposition: form-data; name="input-picture"; filename="breadfruit.jpg"
;;Content-Type: image/jpeg
(let loop ((dat (read-string 1000000 inp))
(res '())
(siz 0))
(if debug-port (format debug-port "dat: ~A\n" dat))
(if debug-port (format debug-port "eof: ~A\n" (eof-object? (read inp))))
(if (> siz maxsize)
(begin
(print "DATA TOO BIG")
res)
(let* ((datstr (open-input-string dat))
(header (formdat:read-header datstr))
(key (if (not (null? header))(car header) #f))
(remdat (read-string #f datstr)) ;; used in next line, discard if got data, else revert to
(alldat (if key (formdat:read-dat remdat key) #f)) ;; try to extract the data
(thsdat (if alldat (car alldat) #f)) ;; the data
(newdat (if alldat (cadr alldat) #f)) ;; left over data, must process ...
(thsres (list header thsdat)) ;; speculatively construct results
(newres (append res (list thsres)))) ;; speculatively construct results
(close-input-port datstr)
(cond
;; either no header or single input
((and (not alldat)
(or (null? header)
(not (string-match formdat:delim-patt-rex (car header)))))
;; (print "Got here")
(cons (list header "") res)) ;; note use header as dat and use "" as header????
;; didn't find end key in this block
((not alldat)
(let ((mordat (read-string 1000000 inp)))
(if (string=? mordat "") ;; there is no more data, discard results and use remdat as data, this input is broken
(cons (list header remdat) res)
(loop (string-append dat mordat) res (+ siz 2000000))))) ;; add the extra 1000000
(alldat ;; got data, don't attempt to check if there is more, just loop and rely on (not alldat) to get more data
(loop newdat newres (+ siz 1000000))))))))
(define formdat:bin-data-disp-rex (regexp "^Content-Disposition:\\s+form-data;"))
(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))
(make-formdat:formdat))))
;; (s:process-cgi-input (caaar dat))
(define (formdat:load-all-port inp)
(let* ((formdat (make-formdat:formdat))
(debugp #f))
;; (open-output-file (conc "/tmp/delme-" (current-user-id) ".log"))))
;; (write-string (read-string #f inp) #f debugp) ;; destroys all data!
(formdat:initialize formdat)
(let ((alldats (formdat:dat->list inp 10e6 debug-port: debugp)))
(if debugp (format debugp "formdat : alldats: ~A\n" alldats))
(let ((firstitem (car alldats))
(multipass #f))
(if (and (not (null? firstitem))
(not (null? (car firstitem))))
(if (string-match formdat:delim-patt-rex (caar firstitem))
(set! multipass #t)))
(if multipass
;; handle multi-part form
(for-each (lambda (datlst)
(let* ((header (formdat:extract-header-info (car datlst)))
(name (if (assoc 'name header)
(string->symbol (cadr (assoc 'name header)))
"")) ;; grumble
(fnamel (assoc 'filename header))
(content (assoc 'content header))
(dat (cadr datlst)))
;; (print "header: " header " name: " name " fnamel: " fnamel " content: " content) ;; " dat: " (dat)
(formdat:set! formdat
name
(if fnamel
(list (cadr fnamel)
(if content
(cadr content)
"unknown")
(string->blob dat))
dat))))
alldats)
;; handle single part form
;; (if (and (string? name)
;; (string=? name "")) ;; this is the short form input I guess
;; (let* ((datstr (caar datlst))
;; (munged (s:process-cgi-input datstr)))
;; (print "datstr: " datstr " munged: " munged)
(if (and (not (null? alldats))
(not (null? (car alldats)))
(not (null? (caar alldats))))
(formdat:load formdat (s:process-cgi-input (caaar alldats))))) ;; munged))
;; (format debugp "formdat : name: ~A content: ~A\n" name content)
;; (if debugp (close-output-port debugp))
;; (sdat-formdat-set! s:session formdat)
formdat))))
#|
(define inp (open-input-file "tests/example.post.in"))
(define dat (read-string #f inp))
(define datstr (open-input-string dat))
;; or
(define inp (open-input-file "tests/example.post.binary.in"))
(define dat (read-string #f inp))
(define datstr (open-input-string dat))
(formdat:read-header datstr)
(define dat (formdat:dat->list inp 10e6))
(close-input-port inp)
|#
(define (formdat:extract-header-info header)
(if (null? header)
'()
(let loop ((hed (car header))
(tal (cdr header))
(res '()))
(if (string-match formdat:bin-data-disp-rex hed) ;;
(let* ((data-namem (string-match formdat:bin-data-name-rex hed))
(file-namem (string-match formdat:bin-file-name-rex hed))
(data-name (if data-namem (cadr data-namem) #f))
(this (if file-namem
(list (list 'name data-name)(list 'filename (cadr file-namem)))
(list (list 'name data-name)))))
(if (null? tal)
(append res this)
(loop (car tal)(cdr tal)(append res this))))
(let ((content (string-match formdat:bin-file-type-rex hed))) ;; this is the stanza for the content type
(if content
(let ((newres (cons (list 'content (cadr content)) res)))
(if (null? tal)
newres
(loop (car tal)(cdr tal) newres)))
(if (null? tal)
res
(loop (car tal)(cdr tal) res)
)))))))
;; (let loop ((l (read-line)) ;; (if (eq? mode 'norm)(read-line)(read-char)))
;; (endline #f)
;; (num 0))
;; ;; (format debugp "~A\n" l)
;; (if (or (not (eof-object? l))
;; (not (and (eq? mode 'bin)
;; (string=? l "")))) ;; if in bin mode empty string is end of file
;; (case mode
;; ((start)
;; (set! mode 'norm)
;; (if (string-match delim-patt-rex l)
;; (begin
;; (set! delim-string l)
;; (set! delim-len (string-length l))
;; (loop (read-line) #f 0))
;; (loop l #f 0)))
;; ((norm)
;; ;; I don't like how this gets checked on every single input. Must be a better way. FIXME
;; (if (and (string-match bin-data-disp-rex l)
;; (string-match bin-data-name-rex l)
;; (string-match bin-file-name-rex l))
;; (begin
;; (set! data-name (cadr (string-match bin-data-name-rex l)))
;; (set! file-name (cadr (string-match bin-file-name-rex l)))
;; (set! mode 'content)
;; (loop (read-line) #f num)))
;; (let* ((dat (s:process-cgi-input l))) ;; (CGI:url-unquote l))
;; (format debugp "PROCESS-CGI-INPUT: ~A\n" (intersperse dat ","))
;; (formdat:load formdat dat)
;; (loop (read-line) #f num)))
;; ((content)
;; (if (string-match bin-file-type-rex l)
;; (begin
;; (set! mode 'bin)
;; (set! data-type (cadr (string-match bin-file-type-rex l)))
;; (loop (read-string 1) #f num))))
;; ((bin)
;; ;; delim-string: \n"---------------12345"
;; ;; 012345678901234567890
;; ;; endline: "---------------12"
;; ;; l = "3"
;; ;; delim-len = 20
;; ;; (substring "---------------12345" 17 18) => "3"
;; ;;
;; (cond
;; ;; haven't found the start of an endline, is the next char a newline?
;; ((and (not endline)
;; (string=? l "\n")) ;; required first character
;; (let ((newendline (open-output-string)))
;; ;; (write-line l newendline) ;; discard the newline. add it back if don't have a lock on delim-string
;; (loop (read-string 1) newendline (+ num 1))))
;; ((not endline)
;; (write-string l #f bin-dat)
;; (loop (read-string 1) #f (+ num 1)))
;; ;; string so far matches delim-string
;; (endline
;; (let* ((endstr (get-output-string endline))
;; (endlen (string-length endstr)))
;; (if (> endlen 0)
;; (format debugp " delim: ~A\nendstr: ~A\n" delim-string endstr))
;; (if (and (> delim-len endlen)
;; (string=? l (substring delim-string endlen (+ endlen 1))))
;; ;; yes, this character matches the next in the delim-string
;; (if (eq? delim-len endlen) ;; have a match! Ignore that a newline is required. Lazy bugger.
;; (let* ((fn (string->symbol data-name)))
;; (formdat:set! formdat fn (list file-name data-type (string->blob (get-output-string bin-dat))))
;; (set! mode 'norm)
;; (loop (read-line) #f 0))
;; (begin
;; (write-string l #f endline)
;; (loop (read-string 1) endline (+ num 1))))
;; ;; no, this character does NOT match the next in line in delim-string
;; (begin
;; (write-string "\n" #f bin-dat) ;; don't forget that newline we dropped
;; (write-string endstr #f bin-dat)
;; (write-string l #f bin-dat)
;; (loop (read-string 1) #f (+ num 1))))))))
;; )))))
;; (formdat:printall formdat (lambda (x)(write-line x debugp)))
#|
(define inp (open-input-file "/tmp/stmlrun/delme-33.log.keep-for-ref"))
(define dat (read-string #f inp))
(close-input-port inp)
|#
;;======================================================================
;; use a table in your db called metadat to store key value pairs
;;======================================================================
(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
(dbi:exec db "UPDATE metadata SET value=? WHERE key=?;" value key)
(dbi:exec db "INSERT INTO metadata (key,value) VALUES (?,?);" key value))))
(define (keystore:del! db key)
(dbi:exec db "DELETE FROM metadata WHERE key=?;" key))
;;======================================================================
;; stuff from misc-stml.scm
;;======================================================================
;; moved to stmlcommon
;; (bunch of stuff)
;; moved from stmlcommon
;;
;; anything except a list is converted to a string!!!
(define (s:any->string val)
(cond
((string? val) val)
((number? val) (number->string val))
((symbol? val) (symbol->string val))
((eq? val #f) "")
((eq? val #t) "TRUE")
((list? val) val)
(else
(let ((ostr (open-output-string)))
(with-output-to-port ostr
(lambda ()
(display val)))
(get-output-string ostr)))))
(define (s:any->number val)
(cond
((number? val) val)
((string? val) (string->number val))
((symbol? val) (string->number (symbol->string val)))
(else #f)))
;; Moved from stmlcommon
;;
(define (s:cgi-out inlst)
(s:output-new (current-output-port) inlst))
#;(define (s:output port inlst)
(map (lambda (x)
(cond
((string? x) (print x)) ;; (print x))
((symbol? x) (print x)) ;; (print x))
((list? x) (s:output port x))
(else ""
;; (print "ERROR: Bad input 02") ;; why do anything? don't output junk.
)))
inlst))
; (if (> (length inlst) 2)
; (print)))
(define (s:output-new port inlst)
(with-output-to-port port
(lambda ()
(map (lambda (x)
(cond
((string? x) (print x))
((symbol? x) (print x))
((list? x) (s:output-new port x))
(else
;; (print "ERROR: Bad input 03")
)))
inlst))))
(define (err:log . msg)
(with-output-to-port (current-error-port) ;; (slot-ref self 'logpt)
(lambda ()
(apply print msg))))
;;======================================================================
;; D B
;;======================================================================
;; convert values to appropriate strings
;;
(define (s:sqlparam-val->string val)
(cond
((list? val)(string-join (map symbol->string val) ",")) ;; (a b c) => a,b,c
((string? val)(conc "'" (dbi:escape-string val) "'"))
((number? val)(number->string val))
((symbol? val)(dbi:escape-string (symbol->string val)))
((boolean? val)
(if val "TRUE" "FALSE")) ;; should this be "TRUE" or 1?
;; should this be "FALSE" or 0 or NULL?
(else
(err:log "sqlparam: unknown type for value: " val)
"")))
;; (sqlparam "INSERT INTO foo(name,age) VALUES(?,?);" "bob" 20)
;; NB// 1. values only!!
;; 2. terminating semicolon required (used as part of logic)
;;
;; a=? 1 (number) => a=1
;; a=? 1 (string) => a='1'
;; a=? #f => a=FALSE
;; a=? a (symbol) => a=a
;;
(define (s:sqlparam query . args)
(let* ((query-parts (string-split query "?"))
(num-parts (length query-parts))
(num-args (length args)))
(if (not (= (+ num-args 1) num-parts))
(err:log "ERROR, sqlparam: wrong number of arguments or missing semicolon, " num-args " for query " query)
(if (= num-args 0) query
(let loop ((section (car query-parts))
(tail (cdr query-parts))
(result "")
(arg (car args))
(argtail (cdr args)))
(let* ((valstr (s:sqlparam-val->string arg))
(newresult (conc result section valstr)))
(if (null? argtail) ;; we are done
(conc newresult (car tail))
(loop
(car tail)
(cdr tail)
newresult
(car argtail)
(cdr argtail)))))))))
;; (define session:valid-chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789")
(define session:valid-chars "abcdefghijklmnopqrstuvwxyz0123456789") ;; cookies are case insensitive.
(define session:num-valid-chars (string-length session:valid-chars))
(define (session:get-nth-char nth)
(substring session:valid-chars nth (+ nth 1)))
(define (session:get-rand-char)
(session:get-nth-char (random session:num-valid-chars)))
(define (session:make-rand-string len)
(let loop ((res "")
(n 1))
(if (> n len) res
(loop (string-append res (session:get-rand-char))
(+ n 1)))))
;; maybe replace above make-rand-string with this someday?
;;
(define (session:generic-make-rand-string len seed-string)
(let ((num-chars (string-length seed-string)))
(let loop ((res "")
(n 1))
(let ((char-num (random num-chars)))
(if (> n len) res
(loop (string-append res (substring seed-string char-num (+ char-num 1)))
(+ n 1)))))))
;;======================================================================
;; P A R A M S
;;======================================================================
;; input: 'a ('a "val a" 'b "val b") => "val a"
(define (s:find-param key param-lst)
(let loop ((head (car param-lst))
(tail (cdr param-lst)))
(if (eq? head key)
(car tail)
(if (< (length tail) 2) #f
(loop (cadr tail)(cddr tail))))))
(define (s:param->string param)
(conc (symbol->string (car param)) "=" "\"" (cadr param) "\""))
;; remove 'foo "bar" from ('foo "bar" 'bar "foo")
(define (s:remove-param-matching params key)
(if (= (length params) 0)'() ;; proper params list >= 2 items
(let loop ((head (car params))
(tail (cdr params))
(result '()))
(if (symbol? head) ;; symbols have params
(let ((val (car tail))
(newtail (cdr tail)))
(if (eq? head key) ;; get rid of this one
(if (null? newtail) result
(loop (car newtail)(cdr newtail) result))
(let ((newresult (append result (list head val))))
(if (null? newtail) newresult
(loop (car newtail)(cdr newtail) newresult)))))
(let ((newresult (append result (list head))))
(if (null? tail) newresult
(loop (car tail)(cdr tail) newresult)))))))
(define (session:get-param-from params key)
(let ((r1 (regexp (conc "^" (s:any->string key) "=(.*)$"))))
(if (null? params) #f
(let loop ((head (car params))
(tail (cdr params)))
(let ((match (string-match r1 head)))
(if match
(list-ref match 1)
(if (null? tail) #f
(loop (car tail)(cdr tail)))))))))
(define (s:process-params params)
(if (null? params) ""
(let loop ((res "")
(head (car params))
(tail (cdr params)))
(if (null? tail)
(conc res " " (s:param->string head))
(loop
(conc res " " (s:param->string head))
(car tail)
(cdr tail))))))
;; remove key=var from (key=var key1=var1 key2=var2 ...)
(define (k=v-params:remove-matching params key)
(if (= (length params) 0) params
(let ((r1 (regexp (conc "^" key "="))))
(let loop ((head (car params))
(tail (cdr params))
(result '()))
(if (string-match r1 head)
(if (null? tail) result
(loop (car tail)(cdr tail) result))
(let ((newlst (cons head result)))
(if (null? tail) newlst
(loop (car tail)(cdr tail) newlst))))))))
;;======================================================================
;; stuff pulled from session
;;======================================================================
;; 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 36))
;; (define (sdat-dbtype vec) (vector-ref vec 0))
;; (define (sdat-dbinit vec) (vector-ref vec 1))
;; (define (sdat-conn vec) (vector-ref vec 2))
;; (define (sdat-pgconn vec) (vector-ref (vector-ref vec 2) 1))
;; (define (sdat-params vec) (vector-ref vec 3))
;; (define (sdat-path-params vec) (vector-ref vec 4))
;; (define (sdat-session-key vec) (vector-ref vec 5))
;; (define (sdat-session-id vec) (vector-ref vec 6))
;; (define (sdat-domain vec) (vector-ref vec 7))
;; (define (sdat-toppage vec) (vector-ref vec 8))
;; (define (sdat-page vec) (vector-ref vec 9))
;; (define (sdat-curr-page vec) (vector-ref vec 10))
;; (define (sdat-content-type vec) (vector-ref vec 11))
;; (define (sdat-page-type vec) (vector-ref vec 12))
;; (define (sdat-sroot vec) (vector-ref vec 13))
;; (define (sdat-twikidir vec) (vector-ref vec 14))
;; (define (sdat-pagedat vec) (vector-ref vec 15))
;; (define (sdat-alt-page-dat vec) (vector-ref vec 16))
;; (define (sdat-pagevars vec) (vector-ref vec 17))
;; (define (sdat-pagevars-before vec) (vector-ref vec 18))
;; (define (sdat-sessionvars vec) (vector-ref vec 19))
;; (define (sdat-sessionvars-before vec) (vector-ref vec 20))
;; (define (sdat-globalvars vec) (vector-ref vec 21))
;; (define (sdat-globalvars-before vec) (vector-ref vec 22))
;; (define (sdat-logpt vec) (vector-ref vec 23))
;; (define (sdat-formdat vec) (vector-ref vec 24))
;; (define (sdat-request-method vec) (vector-ref vec 25))
;; (define (sdat-session-cookie vec) (vector-ref vec 26))
;; (define (sdat-curr-err vec) (vector-ref vec 27))
;; (define (sdat-log-port vec) (vector-ref vec 28))
;; (define (sdat-logfile vec) (vector-ref vec 29))
;; (define (sdat-seen-pages vec) (vector-ref vec 30))
;; (define (sdat-page-dir-style vec) (vector-ref vec 31))
;; (define (sdat-debugmode vec) (vector-ref vec 32))
;; (define (sdat-shared-hash vec) (vector-ref vec 33))
;; (define (sdat-script vec) (vector-ref vec 34))
;; (define (sdat-force-ssl vec) (vector-ref vec 35))
;;
;; (define (session:get-shared vec varname)
;; (hash-table-ref/default (vector-ref vec 33) varname #f))
;;
;; (define (sdat-dbtype-set! vec val)(vector-set! vec 0 val))
;; (define (sdat-dbinit-set! vec val)(vector-set! vec 1 val))
;; (define (sdat-conn-set! vec val)(vector-set! vec 2 val))
;; (define (sdat-params-set! vec val)(vector-set! vec 3 val))
;; (define (sdat-path-set-params! vec val)(vector-set! vec 4 val))
;; (define (sdat-session-set-key! vec val)(vector-set! vec 5 val))
;; (define (sdat-session-set-id! vec val)(vector-set! vec 6 val))
;; (define (sdat-domain-set! vec val)(vector-set! vec 7 val))
;; (define (sdat-toppage-set! vec val)(vector-set! vec 8 val))
;; (define (sdat-page-set! vec val)(vector-set! vec 9 val))
;; (define (sdat-curr-set-page! vec val)(vector-set! vec 10 val))
;; (define (sdat-content-set-type! vec val)(vector-set! vec 11 val))
;; (define (sdat-page-set-type! vec val)(vector-set! vec 12 val))
;; (define (sdat-sroot-set! vec val)(vector-set! vec 13 val))
;; (define (sdat-twikidir-set! vec val)(vector-set! vec 14 val))
;; (define (sdat-pagedat-set! vec val)(vector-set! vec 15 val))
;; (define (sdat-alt-set-page-dat! vec val)(vector-set! vec 16 val))
;; (define (sdat-pagevars-set! vec val)(vector-set! vec 17 val))
;; (define (sdat-pagevars-set-before! vec val)(vector-set! vec 18 val))
;; (define (sdat-sessionvars-set! vec val)(vector-set! vec 19 val))
;; (define (sdat-sessionvars-set-before! vec val)(vector-set! vec 20 val))
;; (define (sdat-globalvars-set! vec val)(vector-set! vec 21 val))
;; (define (sdat-globalvars-set-before! vec val)(vector-set! vec 22 val))
;; (define (sdat-logpt-set! vec val)(vector-set! vec 23 val))
;; (define (sdat-formdat-set! vec val)(vector-set! vec 24 val))
;; (define (sdat-request-set-method! vec val)(vector-set! vec 25 val))
;; (define (sdat-session-set-cookie! vec val)(vector-set! vec 26 val))
;; (define (sdat-curr-set-err! vec val)(vector-set! vec 27 val))
;; (define (sdat-log-set-port! vec val)(vector-set! vec 28 val))
;; (define (sdat-logfile-set! vec val)(vector-set! vec 29 val))
;; (define (sdat-seen-set-pages! vec val)(vector-set! vec 30 val))
;; (define (sdat-page-set-dir-style! vec val)(vector-set! vec 31 val))
;; (define (sdat-debugmode-set! vec val)(vector-set! vec 32 val))
;; (define (sdat-shared-set-hash! vec val)(vector-set! vec 33 val))
;; (define (sdat-script-set! vec val)(vector-set! vec 34 val))
;; (define (sdat-force-set-ssl! vec val)(vector-set! vec 35 val))
;;
;; (define (session:set-shared! vec varname val)
;; (hash-table-set! (vector-ref vec 33) varname val))
;; The global session
(define s:session (make-sdat))
;; SPLIT INTO STRAIGHT FORWARD INIT AND COMPLEX INIT
#;(define (session:initialize self #!optional (configf #f))
(sdat-dbtype-set! self 'pg)
(sdat-page-set! self "home") ;; these are defaults
(sdat-curr-set-page! self "home")
(sdat-content-set-type! self "Content-type: text/html; charset=iso-8859-1\n\n")
(sdat-page-set-type! self 'html)
(sdat-toppage-set! self "index")
(sdat-params-set! self '()) ;;
(sdat-path-set-params! self '())
(sdat-session-set-key! self #f)
(sdat-pagedat-set! self '())
(sdat-alt-set-page-dat! self #f)
(sdat-sroot-set! self "./")
(sdat-session-set-cookie! self #f)
(sdat-curr-set-err! self #f)
(sdat-log-set-port! self (current-error-port))
(sdat-seen-set-pages! self '())
(sdat-page-set-dir-style! self #t) ;; #t : pages/<pagename>_(view|cntl).scm
;; #f : pages/<pagename>/(view|control).scm
(sdat-debugmode-set! self #f)
(sdat-pagevars-set! self (make-hash-table))
(sdat-sessionvars-set! self (make-hash-table))
(sdat-globalvars-set! self (make-hash-table))
(sdat-pagevars-set-before! self (make-hash-table))
(sdat-sessionvars-set-before! self (make-hash-table))
(sdat-globalvars-set-before! self (make-hash-table))
(sdat-domain-set! self "locahost") ;; end of defaults
(sdat-script-set! self #f)
(sdat-force-set-ssl! self #f)
(let* ((rawconfigdat (session:read-config self configf))
(configdat (if rawconfigdat (eval rawconfigdat) '()))
(sroot (s:find-param 'sroot configdat))
(logfile (s:find-param 'logfile configdat))
(dbtype (s:find-param 'dbtype configdat))
(dbinit (s:find-param 'dbinit configdat))
(domain (s:find-param 'domain configdat))
(twikidir (s:find-param 'twikidir configdat))
(page-dir (s:find-param 'page-dir-style configdat))
(debugmode (s:find-param 'debugmode configdat))
(script (s:find-param 'script configdat))
(force-ssl (s:find-param 'force-ssl configdat)))
(if sroot (sdat-sroot-set! self sroot))
(if logfile (sdat-logfile-set! self logfile))
(if dbtype (sdat-dbtype-set! self dbtype))
(if dbinit (sdat-dbinit-set! self dbinit))
(if domain (sdat-domain-set! self domain))
(if twikidir (sdat-twikidir-set! self twikidir))
(if debugmode (sdat-debugmode-set! self debugmode))
(if script (sdat-script-set! self script))
(if force-ssl (sdat-force-set-ssl! self force-ssl))
(sdat-page-set-dir-style! self page-dir)
;; (print "configdat: ")(pp configdat)
(if debugmode
(session:log self "sroot: " sroot " logfile: " logfile " dbtype: " dbtype
" dbinit: " dbinit " domain: " domain " page-dir-style: " page-dir))
)
(sdat-shared-set-hash! self (make-hash-table))
)
;; Used for the strangely inconsistent handling of the config file. A better way is needed.
;;
;; (let ((dbtype (sdat-dbtype self)))
;; (print "dbtype: " dbtype)
;; (sdat-dbtype-set! self (eval dbtype))))
(define (session:setup self #!optional (configf #f))
(session:initialize self configf)
(let ((dbtype (sdat-dbtype self))
(debugmode (sdat-debug-mode self))
(dbinit (eval (sdat-dbinit self)))
(dbexists #f))
(let ((dbfname (alist-ref 'dbname dbinit)))
(if debugmode (session:log self "session:setup dbfname=" dbfname ", dbtype=" dbtype ", dbinit=" dbinit))
(if (eq? dbtype 'sqlite3)
;; The 'auto method will distribute dbs across the disk using hash
;; of user host and user. TODO
;; (if (eq? dbfname 'auto) ;; This is the auto assignment of a db based on hash of IP
(let ((dbpath (pathname-directory dbfname))) ;; do a couple sanity checks here to make setting up easier
(if debugmode (session:log self "INFO: setting up for sqlite3 db access to " dbfname))
(if (not (file-write-access? dbpath))
(session:log self "WARNING: Cannot write to " dbpath)
(if debugmode (session:log self "INFO: " dbpath " is writeable")))
(if (file-exists? dbfname)
(begin
;; (session:log self "setting dbexists to #t")
(set! dbexists #t))))
(if debugmode (session:log self "INFO: setting up for pg db access to account info " dbinit)))
(if debugmode (session:log self "dbtype: " dbtype " dbfname: " dbfname " dbexists: " dbexists)))
(sdat-conn-set! self (dbi:open dbtype dbinit))
(set! *db* (sdat-conn self))
(if (and (not dbexists)(eq? dbtype 'sqlite3))
(begin
(print "WARNING: Setting up session db with sqlite3")
(session:setup-db self)))
(session:process-url-path self)
(session:setup-session-key self)
;; capture stdin if this is a POST
(sdat-request-method-set! self (get-environment-variable "REQUEST_METHOD"))
(sdat-formdat-set! self (formdat:load-all))))
;; setup the db with session tables, works for sqlite only right now
(define (session:setup-db self)
(let ((conn (sdat-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-session-set-id! self (session:get-id self)))
;; only set session-cookie when a new session is created
(define (session:setup-session-key self)
(let* ((sk (session:extract-session-key self))
(sid (if sk (session:get-id self sk) #f)))
(if (not sid) ;; need a new key
(let* ((new-key (session:get-new-key self))
(new-sid (session:get-id self new-key)))
(sdat-session-key-set! self new-key)
(sdat-session-id-set! self new-sid)
(sdat-session-cookie-set! self (session:make-cookie self)))
(sdat-session-id-set! self sid))))
(define (session:make-cookie self)
;; (list (conc "session_key=" (sdat-session-key self) "; Path=/; Domain=." (sdat-domain self) "; Max-Age=" (* 86400 14) "; Version=1")))
;; According to
;; http://www.codemarvels.com/2010/11/apache-rewriterule-set-a-cookie-on-localhost/
;; Here are the 2 (often left out) requirements to set a cookie using
;; httpd-F�s rewrite rule (mod_rewrite), while working on localhost:-A
;;
;; Use the IP 127.0.0.1 instead of localhost/machine-name as the
;; domain; e.g. [CO=someCookie:someValue:127.0.0.1:2:/], which says
;; create a cookie -Y�someCookie� with value �someValue� for the
;; domain �127.0.0.1$B!m(B having a life time of 2 mins, for any path in
;; the domain (path=/). (Obviously you will have to run the
;; application with this value in the URL)
;;
;; To make a session cookie, limit the flag statement to just three
;; attributes: name, value and domain. e.g
;; [CO=someCookie:someValue:127.0.0.1] %G–%@ Any further
;; settings, apache writes an� expires� attribute for the set-cookie
;; header, which makes the cookie a persistent one (not really
;; persistent, as the expires value set is the current server time
;; %G–%@ so you don-F-F�t even get to see your cookie!)-A
(list (string-substitute
";" "; "
(car (construct-cookie-string
;; warning! messing up this itty bitty bit of code will cost much time!
`(("session_key" ,(sdat-session-key self)
expires: ,(+ (current-seconds) (* 14 86400))
;; max-age: (* 14 86400)
path: "/" ;;
domain: ,(string-append "." (sdat-domain self))
version: 1)) 0)))))
;; look up a given session key and return the id if found, #f if not found
(define (session:get-id self session-key)
;; (let ((session-key (sdat-session-key self)))
(if session-key
(let ((query (string-append "SELECT id FROM sessions WHERE session_key='" session-key "'"))
(conn (sdat-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-page-set! self (car parts)))
;; (session:log self "url-path=" url-path " parts=" parts)
(if (> numparts 1)
(sdat-path-params-set! self (cdr parts)))
(if query-string
(sdat-params-set! self (string-split query-string "&")))))))
;; BUGGY!
(define (session:get-new-key self)
(let ((conn (sdat-conn self))
(tmpkey (session:make-rand-string 20))
(status #f))
(dbi:for-each-row (lambda (tuple)
(set! status #t))
conn (string-append "INSERT INTO sessions (session_key) VALUES ('" tmpkey "')"))
tmpkey))
;; returns session key IFF it is in the HTTP_COOKIE
(define (session:extract-session-key self)
(let ((http-cookie (get-environment-variable "HTTP_COOKIE")))
;; (err:log "http-cookie: " http-cookie)
(if http-cookie
(session:extract-key-from-param self (string-split-fields ";\\s+" http-cookie infix:) "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-conn self))
;; conn)
(dbi:for-each-row (lambda (tuple)
(set! result (vector-ref tuple 0))) ;; (vector-ref tuple 0)))
(sdat-conn self)
(s:sqlparam query session-key))
result))
;; delete all records for a session
;;
;; NEEDS TO BE TRANSACTIONIZED!
;;
(define (session:delete-session self session-key)
(let ((session-id (session:get-session-id self session-key))
(qry1 ;; (conc "BEGIN;"
"DELETE FROM session_vars WHERE session_id=?;")
(qry2 "DELETE FROM sessions WHERE id=?;")
;; "COMMIT;"))
(conn (sdat-conn self)))
(if session-id
(begin
(dbi:exec conn qry1 session-id) ;; session-id)
(dbi:exec conn qry2 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-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-params self)))
(session:extract-key-from-param self params key)))
(define (session:extract-key-from-param self params key)
(let ((r1 (regexp (string-append "^" key "=([^=]+)$"))))
(err:log "INFO: Looking for " key " in " params)
(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)))
(err:log "INFO: Found session key=" session-key)
(sdat-session-key-set! self (list-ref match 1))
session-key))
((null? tail)
#f)
(else
(loop (car tail)
(cdr tail)))))))))
(define (session:set-page! self page_name)
(sdat-page-set! self page_name))
(define (session:close self)
(dbi:close (sdat-conn self)))
;; (close-output-port (sdat-logpt self))
(define (session:err-msg self msg)
(hash-table-set! (sdat-sessionvars self) "ERROR_MSG"
(string-intersperse (map s:any->string msg) " ")))
(define (session:prev-err self)
(let ((prev-err (hash-table-ref/default (sdat-sessionvars-before self) "ERROR_MSG" #f))
(curr-err (hash-table-ref/default (sdat-sessionvars self) "ERROR_MSG" #f)))
(if prev-err prev-err
(if curr-err curr-err #f))))
;; session vars
;; 1. keys are always a string NOT a symbol
;; 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:curr-page-set! self key value)
(hash-table-set! (sdat-pagevars self) (s:any->string key) (s:any->string value)))
;; del a var for the current page
;;
(define (session:page-var-del! self key)
(hash-table-delete! (sdat-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-sessionvars self)
(if (string=? page "*globalvars*")
(sdat-globalvars self)
(sdat-pagevars self))))
;; set a session var for a given page
;;
(define (session:set! self page key value)
(let ((ht (session:get-page-hash self page)))
(hash-table-set! ht (s:any->string key) (s:any->string value))))
;; get session vars for the current page
;;
(define (session:page-get self key)
(hash-table-ref/default (sdat-pagevars self) key #f))
;; get session vars for a specified page
;;
(define (session:get self page key params)
(let* ((ht (session:get-page-hash self page))
(res (hash-table-ref/default ht (s:any->string key) #f)))
(session:apply-type-preference res params)))
;; 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 (s:any->string key))))
;; get ALL keys for this page and store in the session pagevars hash
;;
(define (session:get-vars self)
(let ((session-id (sdat-session-id self)))
(if (not session-id)
(err:log "ERROR: No session id in session object! session:get-vars")
(let* ((result #f)
(conn (sdat-conn self))
(pagevars-before (sdat-pagevars-before self))
(sessionvars-before (sdat-sessionvars-before self))
(globalvars-before (sdat-globalvars-before self))
(pagevars (sdat-pagevars self))
(sessionvars (sdat-sessionvars self))
(globalvars (sdat-globalvars self))
(page-name (sdat-page self))
(session-key (sdat-session-key self))
(query (string-append
"SELECT key,value FROM session_vars INNER JOIN sessions ON session_vars.session_id=sessions.id "
"WHERE session_key=? AND page=?;")))
;; first the page specific vars
(dbi:for-each-row (lambda (tuple)
(let ((k (vector-ref tuple 0))
(v (vector-ref tuple 1)))
(hash-table-set! pagevars-before k v)
(hash-table-set! pagevars k v)))
conn
(s:sqlparam query session-key page-name))
;; then the session specific vars
(dbi:for-each-row (lambda (tuple)
(let ((k (vector-ref tuple 0))
(v (vector-ref tuple 1)))
(hash-table-set! sessionvars-before k v)
(hash-table-set! sessionvars k v)))
conn
(s:sqlparam query session-key "*sessionvars*"))
;; and finally the global vars
(dbi:for-each-row (lambda (tuple)
(let ((k (vector-ref tuple 0))
(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-session-id self)))
(if (not session-id)
(err:log "ERROR: No session id in session object! session:get-vars")
(let* ((status #f)
(conn (sdat-conn self))
(page-name (sdat-page self))
(del-query "DELETE FROM session_vars WHERE session_id=? AND page=? AND key=?;")
(ins-query "INSERT INTO session_vars (session_id,page,key,value) VALUES(?,?,?,?);")
(upd-query "UPDATE session_vars set value=? WHERE key=? AND session_id=? AND page=?;")
(changed-count 0))
;; save the delta only
(for-each
(lambda (page) ;; page is: "*globalvars*" "*sessionvars*" or otherstring
(let* ((before-after-ht (cond
((string=? page "*sessionvars*")
(vector (sdat-sessionvars self)
(sdat-sessionvars-before self)))
((string=? page "*globalvars*")
(vector (sdat-globalvars self)
(sdat-globalvars-before self)))
(else
(vector (sdat-pagevars self)
(sdat-pagevars-before self)))))
(master-ht (vector-ref before-after-ht 0))
(before-ht (vector-ref before-after-ht 1))
(master-keys (hash-table-keys master-ht))
(before-keys (hash-table-keys before-ht))
(all-keys (delete-duplicates (append master-keys before-keys))))
(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)))
(cond
;; before and after exist and value unchanged - do nothing
((and master-value before-value (equal? master-value before-value)))
;; before and after exist but are changed
((and master-value before-value)
(dbi:for-each-row (lambda (tuple)
(set! changed-count (+ changed-count 1)))
conn
(s:sqlparam upd-query master-value key session-id page)))
;; master-value no longer exists (i.e. #f) - remove item
((not master-value)
(dbi:for-each-row (lambda (tuple)
(set! changed-count (+ changed-count 1)))
conn
(s:sqlparam del-query session-id page key)))
;; before-value doesn't exist - insert a new value
((not before-value)
(dbi:for-each-row (lambda (tuple)
(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 #!optional (fname #f))
(let* ((cgi-path (pathname-directory (car (argv))))
(name (or fname (string-append (if cgi-path (conc cgi-path "/") "") "." (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))))
;; call the controller if it exists
;;
;; WARNING - this code needs a defense agains recursive calling!!!!!
;;
;; I suggest a limit of 100 calls. Plenty for allowing multiple instances
;; of a page inside another page.
;;
;; parts = 'both | 'control | 'view
;;
(define (files-read->string . files)
(string-intersperse
(apply append (map file-read->string files)) "\n"))
(define (file-read->string f)
(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))))))
(define (session:process-file f)
(let* ((p (open-input-file f))
(dat (process-port p)))
(close-input-port p)
dat))
;; 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 ...
;; page-dir-style is:
;; 'stored => stored in executable
;; 'flat => pages flat directory
;; 'dir => directory tree pages/<pagename>/{view,control}.scm
;; parts:
;; 'both => load control and view (anything other than view or control and the default)
;; 'view => load view only
;; 'control => load control only
(define (session:call-parts self page #!key (parts 'both))
(sdat-curr-page-set! self page)
(let* ((dir-style (sdat-page-dir-style self));; (equal? (sdat-page-dir-style self) "onedir")) ;; flag #t for onedir, #f for old style
(dir (string-append (sdat-sroot self)
(if dir-style
(conc "/pages/")
(conc "/pages/" page)))))
(case dir-style
;; NB// Stored always loads both control and view
((stored)
((eval (string->symbol (conc "pages:" page)))
self ;; the session
(sdat-conn self) ;; the db connection
(sdat-shared-hash self) ;; a shared hash table for passing data to/from page calls
))
((flat)
(let* ((so-file (conc dir page ".so"))
(scm-file (conc dir page ".scm"))
(src-file (or (file-exists? so-file)
(file-exists? scm-file))))
(if src-file
(begin
(load src-file)
((eval (string->symbol (conc "pages:" page)))
self ;; the session
(sdat-conn self) ;; the db connection
(sdat-shared-hash self) ;; a shared hash table for passing data to/from page calls
))
(list "<p>Page not found " page " </p>"))))
;; first the control
;; (let ((control-file (conc "pages/" page "_ctrl.scm"))
;; (view-file (conc "pages/" page "_view.scm")))
;; (if (and (file-exists? control-file)
;; (not (eq? parts 'view)))
;; (begin
;; (session:set-called! self page)
;; (load control-file)))
;; (if (file-exists? view-file)
;; (if (not (eq? parts 'control))
;; (session:process-file view-file))
;; (list "<p>Page not found " page " </p>")))
((dir) "ERROR: dir style not yet re-implemented")
(else
(list "ERROR: page-dir-style must be stored, dir or flat, got " dir-style)))))
(define (session:call self page parts)
(session:call-parts self page 'both))
(define (session:load-model self model)
(let* ((mpath (session:model-path self))
(model.scm (string-append mpath "/" model ".scm"))
(model.so (string-append mpath "/" 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)
(or (sdat-models self)
(string-append (sdat-sroot self) "/models/")))
(define (session:pp-formdat self)
(let ((dat (formdat:all->strings (sdat-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* ((https-host (get-environment-variable "HTTPS_HOST"))
(force-ssl (sdat-force-ssl self))
(server (or https-host ;; Assuming HTTPS_HOST is only set if available
(get-environment-variable "HTTP_HOST")
(get-environment-variable "SERVER_NAME")
(sdat-domain self)))
(force-script (sdat-script self))
(script (or force-script
(let ((script-name (string-split (get-environment-variable "SCRIPT_NAME") "/")))
(if (> (length script-name) 1)
(string-append (car script-name) "/" (cadr script-name))
(get-environment-variable "SCRIPT_NAME"))))) ;; build script name from first two elements. This is a hangover from before I used ? in the URL.)
(session-key (sdat-session-key self))
(paramstr (session:param->string params)))
(session:log self "server=" server " script=" script " page=" page)
(string-append (if (or https-host force-ssl)
"https://"
"http://")
server "/" script "/" page "?" paramstr))) ;; "/sn=" session-key)))
(define (session:cgi-out self)
(let* ((content (list (sdat-content-type self))) ;; '("Content-type: text/html; charset=iso-8859-1\n\n"))
(header (let ((cookie (sdat-session-cookie self)))
(if cookie
(cons (string-append "Set-Cookie: " (car cookie))
content)
content)))
(pagedat (sdat-pagedat self)))
(s:cgi-out
(cons header pagedat))))
(define (session:log self . msg)
(with-output-to-port (sdat-log-port self) ;; (sdat-logpt self)
(lambda ()
(apply print msg))))
;; escape, convert or return raw when given user input data that potentially
;; could be malicious
;;
(define (session:apply-type-preference res params)
(let* ((dtype (if (null? params)
'escaped
(car params)))
(tags (if (null? params)
'()
(cdr params))))
(case dtype
((raw) res)
((number) (if (string? res)(string->number res) #f))
((escaped) (if (string? res)
(s:html-filter->string res tags)
res))
((escaped-nl) (if (string? res) ;; escape \n and \r
(string-intersperse
(string-split
(string-intersperse
(string-split (s:html-filter->string res tags) "\n")
"\\n")
"\r")
"\\r")
res)) ;; should return #f if not a string and can't escape it?
(else (if (string? res)
(s:html-filter->string res '())
res)))))
#;(define (session:get-param-from params key)
(let ((r1 (regexp (conc "^" (s:any->string key) "=(.*)$"))))
(if (null? params) #f
(let loop ((head (car params))
(tail (cdr params)))
(let ((match (string-match r1 head)))
(if match
(list-ref match 1)
(if (null? tail) #f
(loop (car tail)(cdr tail)))))))))
;; params are stored as list of key=val
;;
(define (session:get-param self key type-params)
;; (session:log s:session "params=" (slot-ref s:session 'params))
(let* ((params (sdat-params self))
(res (session:get-param-from params key)))
(session:apply-type-preference res type-params)))
;; This one will get the first value found regardless of form
;; param: (dtype [tag1 tag2 ...])
;; dtype:
;; 'raw : do no conversion
;; 'number : convert to number, return #f if fails
;; 'escaped : use html-escape to protect the input -- this is the default
;;
(define (session:get-input self key params)
(let* ((dtype (if (null? params)
'escaped
(car params)))
(tags (if (null? params)
'()
(cdr params)))
(formdat (sdat-formdat self))
(res (if (not formdat) #f
(if (or (string? key)(number? key)(symbol? key))
(if (and (vector? formdat)
(eq? (vector-length formdat) 1)
(hash-table? (vector-ref formdat 0)))
(formdat:get formdat key)
(begin
(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) (if (string? res)
(s:html-filter->string res tags)
res))
(else (if (string? res)
(s:html-filter->string res '())
res)))))
;; This one will get the first value found regardless of form
(define (session:get-input-keys self)
(let* ((formdat (sdat-formdat self)))
(if (not formdat) #f
(if (and (vector? formdat)
(eq? (vector-length formdat) 1)
(hash-table? (vector-ref formdat 0)))
(formdat:keys formdat)
(begin
(session:log self "ERROR: formdat: " formdat " is not of class <formdat>")
#f)))))
(define (session:run-actions self)
(let* ((action (session:get-param self 'action '(raw)))
(page (sdat-page self)))
;; (print "action=" action " page=" page)
(if action
(let ((action-lst (string-split action ".")))
;; (print "action-lst=" action-lst)
(if (not (= (length action-lst) 2))
(err:log "Action should be of form: module.action")
(let* ((targ-page (car action-lst))
(proc-name (string-append targ-page "-action"))
(targ-action (cadr action-lst)))
;; (err:log "targ-page=" targ-page " proc-name=" proc-name " targ-action=" targ-action)
;; call here only if never called before
(if (session:never-called-page? self targ-page)
(session:call-parts self targ-page 'control))
;; proc action
(if #t ;; set to #t to see better error messages during debuggin :-)
((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-seen-pages self))))
(define (session:set-called! self page)
(sdat-seen-pages-set! self (cons page (sdat-seen-pages self))))
;;======================================================================
;; Alternative data type delivery
;;======================================================================
(define (session:alt-out self)
(let ((dat (sdat-alt-page-dat self)))
;; (s:log "dat is: " dat)
;; (print "HTTP/1.1 200 OK")
(print "Date: " (time->string (seconds->utc-time (current-seconds))))
(print "Content-Type: " (sdat-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))))
;;======================================================================
;; Orphaned functions
;;======================================================================
;; was in setup
;;
(define (s:log . msg)
(apply session:log s:session msg))
;; Usage: (s:get-err s:big)
(define (s:get-err wrapperfunc)
(let ((errmsg (sdat-curr-err s:session)))
(if errmsg ((if wrapperfunc
wrapperfunc
s:strong) errmsg) '())))
(define (stml:cgi-session session #!optional (configf #f))
;; (session:initialize session)
(session:setup session configf)
(session:get-vars session)
(sdat-log-port-set! session ;; (current-error-port))
(open-output-file (sdat-logfile session) #:append))
(s:validate-inputs)
(change-directory (sdat-sroot session))
(session:run-actions session)
(sdat-pagedat-set! session
(append (sdat-pagedat session)
(s:call (sdat-toppage session))))
(if (eq? (sdat-page-type session) 'html) ;; default is html.
(session:cgi-out session)
(session:alt-out session))
(session:save-vars session)
(session:close session))
(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))))
(define (s:error-page . err)
(s:cgi-out (cons "Content-type: text/html; charset=iso-8859-1\n\n"
(s:html (s:head
(s:title err)
(s:body
(s:h1 "ERROR")
(s:p err)))))))
(define (stml:main proc #!optional (configf #f))
(handle-exceptions
exn
(if (sdat-debug-mode s:session)
(begin
(print "Content-type: text/html")
(print "")
(print "<html> <head> <title>EXCEPTION</title> </head> <body>")
(print " QUERY_STRING is: <b> " (get-environment-variable "QUERY_STRING") " </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)
(print "<tr><td>" (car var) "</td><td>" (cdr var) "</td></tr>"))
(get-environment-variables))
(print "</table>")
(print "</body></html>"))
(begin
(with-output-to-file (conc "/tmp/stml-crash-" (current-process-id) ".log")
(lambda ()
(print "EXCEPTION")
(print " QUERY_STRING is: " (get-environment-variable "QUERY_STRING") )
(print "")
;; (print " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
(print-error-message exn)
(print-call-chain)
(print "")
(for-each (lambda (var)
(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-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)
;; (print "<tr><td>" (car var) "</td><td>" (cdr var) "</td></tr>"))
;; (get-environment-variables))
;; (print "</table>")
(print "</body></html>")))
(if proc (proc s:session) (stml:cgi-session s:session configf))
;; (raise-error)
;; (exit)
))
;; find out if we are in debugmode
(define (s:debug-mode?)
(sdat-debug-mode s:session))
(define (s:never-called-page? page)
(session:never-called-page? s:session page))
(define (s:set-err . args)
(sdat-curr-err-set! s:session args))
(define (s:current-page)
(sdat-page s:session))
(define (s:delete-session)
(session:delete-session s:session (sdat-session-key s:session)))
(define (s:call page . partsl)
(if (null? partsl)
(session:call s:session page #f)
(session:call s:session page (car partsl))))
(define (s:link-to page . params)
(session:link-to s:session page params))
(define (s:get-param key . type-params)
(session:get-param s:session key type-params))
;; these are page local
(define (s:get key)
(session:page-get s:session key))
(define (s:set! key val)
(session:curr-page-set! s:session key val))
(define (s:del! key)
(session:page-var-del! s:session key))
#;(define (s:get-n-del! key)
(let ((val (session:page-get s:session key)))
(session:del! s:session val key)
val))
;; these are session wide
(define (s:session-var-get key . params)
(session:get s:session "*sessionvars*" key params))
(define (s:session-var-set! key val)
(session:set! s:session "*sessionvars*" key val))
(define (s:session-var-get-n-del! key)
(let ((val (session:page-get s:session key)))
(session:del! s:session "*sessionvars*" key)
val))
(define (s:session-var-del! key)
(session:del! s:session "*sessionvars*" key))
(define s:session-var-delete! s:session-var-del!)
;; utility to get all vars as hash table
(define (s:session-get-sessionvars)
(sdat-sessionvars s:session))
;;======================================================================
;; Sugar
;;======================================================================
;;
;; (require 'syntax-case)
;;
;; (define-syntax s:if-param
;; (syntax-rules ()
;; [(_ s x) (if (s:get s) x (s:comment "s:if not"))]
;; [(_ s x y) (if (s:get s) x y)]))
;; ;;
;; (define-syntax s:if-test
;; (syntax-rules ()
;; [(_ s x) (if (string=? "yep" s) x (list "s:if not"))]
;; [(_ s x y) (if (string=? "yep" s) x y)]))
;; Some of these routines use:
;;
;; http://www.cs.toronto.edu/~gfb/scheme/simple-macros.html
;;
;; Syntax for defining macros in a simple style similar to function definiton,
;; when there is a single pattern for the argument list and there are no keywords.
;;
;; (define-simple-syntax (name arg ...) body ...)
;;
(define-syntax define-simple-syntax
(syntax-rules ()
((_ (name arg ...) body ...)
(define-syntax name (syntax-rules () ((name arg ...) (begin body ...)))))))
;;======================================================================
;; syntatic sugar items
;;======================================================================
;; We often seem to want to include stuff if a conditional is met
;; otherwise not include it. This routine makes that slightly cleaner
;; since using a pure if results in #<undefined> objects. (admittedly they
;; should be ignored but this is slightly cleaner I think).
;;
;; NOTE: This has to be a macro or the true clause will be evaluated
;; whether "a" is true or false
;; If a is true return b, else return '()
(define-simple-syntax (s:if a b)
(if a b '()))
;; Using the Simple-Syntax System
;;
;; The syntax for defining macros in this system is similar to that for defining functions. In fact if the macro has a fixed number of arguments the syntax is identical. For example:
;;
;; ; Define a simple macro to add a value to a variable.
;; ;
;; (define-simple-syntax (+= variable value)
;; (set! variable (+ variable value)))
;;
;; ; Use it.
;; ;
;; (define v 2)
;; (+= v 7)
;; v ; => 9
;;
;; For a fixed number of arguments followed by an unknown number of arguments we use ... after a single argument to represent the unknown number (possibly zero) of arguments. For example, let's revise our definition of += to allow zero or more values to be added:
;;
;; ; Define a simple macro to add a zero or more values to a variable
;; ;
;; (define-simple-syntax (+= variable value ...)
;; (set! variable (+ variable value ...)))
;;
;; ; Use it
;; ;
;; (define v 2)
;; (+= v 7)
;; v ; => 9
;; (+= v 3 4)
;; v ; => 16
;; (+= v)
;; v ; => 16
;;
(define-simple-syntax (s:if-param varname first ...)
(if (s:get varname)
(begin
first
...)
'()))
(define-simple-syntax (s:if-sessionvar varname first ...)
(if (s:session-var-get varname)
(begin
first
...)
'()))
;; (define-macro (s:if-param varname ...)
;; (match dat
;; (() '())
;; ((a) `(if (s:get ,varname) ,a '()))
;; ((a b) `(if (s:get ,varname) ,a ,b))))
;;
;; (define-macro (s:if-sessionvar varname . dat)
;; (match dat
;; (() '())
;; ((a) `(if (s:session-var-get ,varname) ,a '()))
;; ((a b) `(if (s:session-var-get ,varname) ,a ,b))))
;;
)