install.cfg
requirements.scm

#
# Following needed on bluehost (maybe on all 64bit?)
#
# CSC_OPTIONS='-C "-fPIC"' make
#
include install.cfg

SRCFILES    = stml2.scm misc-stml.scm session.scm sqltbl.scm formdat.scm setup.scm keystore.scm html-filter.scm cookie.scm 
MODULEFILES = $(wildcard modules/*/*-mod.scm)
SOFILES     = $(MODULEFILES:%.scm=%.so)
CFILES      = $(MODULEFILES:%.scm=%.c)
OFILES      = $(SRCFILES:%.scm=%.o)
TARGFILES   = $(notdir $(SOFILES))
MODULES     = $(addprefix $(TARGDIR)/modules/,$(TARGFILES))

install : $(TARGDIR)/stmlrun $(LOGDIR) $(MODULES)
	chicken-install

all : $(SOFILES)

# stmlrun : stmlrun.scm formdat.scm  misc-stml.scm  session.scm stml.scm \
#           setup.scm html-filter.scm requirements.scm keystore.scm \
#           cookie.scm sqltbl.scm
# 	csc stmlrun.scm

$(TARGDIR)/stmlrun : stmlrun stml2.so
	echo "NOTE: CSC_OPTIONS='-C \"-fPIC\"' make"
	install stmlrun $(TARGDIR)
	chmod a+rx $(TARGDIR)/stmlrun

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

# Cookie is a special case for now. Make a loadable so for test
# Complile it in by include (see dependencies above).
cookie.so : cookie.scm
	csc i$(CSCOPTS) -s cookie.scm

clean :
	rm -f doc/*~ modules/*/*.so *.import.scm *.import.so *.o *.so *~

# $(CFILES): build/%.c: ../scm/%.scm ../scm/macros.scm
# 	chicken $< -output-file $@
# 
# 
# $(OFILES): src/%.o: src/%.c
# 	gcc -c $< `chicken-config -cflags` -o $@
# 
# $(src_code): %: src/%.o src/laedlib.o src/layobj.o
# 	gcc src/$*.o src/laedlib.o src/layobj.o -o $* `chicken-config -libs`
# 

;;   <ftp://ftp.isi.edu/in-notes/rfc2965.txt>
;; See also
;; RFC 2964 Use of HTTP state management
;;   <ftp://ftp.isi.edu/in-notes/rfc2964.txt>
;; The parser also supports the old Netscape spec
;;   <http://www.netscape.com/newsref/std/cookie_spec.html>

;; (declare (unit cookie))

(module cookie
    *

(import chicken scheme data-structures extras srfi-13 ports posix)
  
(require-extension srfi-1 srfi-13 srfi-14 regex)
;; (use  srfi-1 srfi-13 srfi-14 regex)
;; (declare (export parse-cookie-string construct-cookie-string))

;; #>
;; #include <time.h>
;; <#

 
 ;;;; Added support functions from my utils, split this out
 
 (define (string-search-after r s #!optional (start 0))
   (and-let* ((match-indices (string-search-positions r s start))
 	     (right-match (second (first match-indices))))
     (substring s right-match)))
)

;; Copyright 2007-2011, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

;; (declare (unit formdat))

(module formdat
    *

(import chicken scheme data-structures extras srfi-13 ports )
(use html-filter)

(use regex)
(require-extension srfi-69)

(define formdat:*debug* #f)

;; Old data format was something like this. BUT! 
;; Forms do not have names so the hierarcy is

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

)

;; Copyright 2007-2011, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

;; (declare (unit html-filter))

(module html-filter
    *

(import chicken scheme data-structures extras srfi-13 ports )
(use misc-stml)

(require-extension regex)

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

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

;;  PURPOSE.

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

;; (declare (unit keystore))

(module keystore
    *

(import chicken scheme data-structures extras srfi-13 ports )


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

)

;; Copyright 2007-2011, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

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

;; (declare (unit misc-stml))

(module misc-stml
  *

(import chicken scheme data-structures extras srfi-13 ports posix)
  
(use regex (prefix dbi dbi:))
(use (prefix crypt c:))
(use (prefix dbi dbi:))
;; 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 (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))))
           
(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)

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

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

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

)

;; 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))
(module session
    *
  
(import chicken scheme data-structures extras srfi-13 ports posix files srfi-1)
(use formdat html-filter misc-stml)

(use (prefix dbi dbi:) srfi-69)
(require-extension regex)
(use cookie) ;; (declare (uses cookie))

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

;; session_vars table
;; id session_id page_id key value

			  "\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-get-params self))
	 (res    (session:get-param-from params key)))
    (session:apply-type-preference res type-params)))

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

;; was in setup
;;
(define (s:log . msg)
  (apply session:log s:session msg))

)

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

(module setup
    *
(import chicken scheme data-structures extras srfi-13 ports posix)

(uses session misc-stml)
;; (declare (unit setup))
;; (declare (uses session))
(require-extension srfi-69)
(require-extension regex)

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




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

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

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

;; find out if we are in debugmode
(define (s:debug-mode?)
  (sdat-get-debugmode s:session))

)

;;    query-params ;; list of params for the query
;;    conn         ;; connection to db
;;    num-rows     ;; whatever 
;;    curr-row-ptr ;; number of the current row
;;    curr-row     ;; the current row vector (?? do we really want this ??)
;;    ))

(module sqltbl
    *

(import chicken scheme data-structures extras srfi-13 ports )

;; (declare (unit sqltbl))

(define (make-sqltbl:tbl)(make-vector 9))
(define (sqltbl:tbl-get-rows           vec)    (vector-ref  vec 0))
(define (sqltbl:tbl-get-fields         vec)    (vector-ref  vec 1))
(define (sqltbl:tbl-get-fields-hash    vec)    (vector-ref  vec 2))
(define (sqltbl:tbl-get-query          vec)    (vector-ref  vec 3))
(define (sqltbl:tbl-get-query-params   vec)    (vector-ref  vec 4))

;; runs proc on each row and returns the resulting list
(define (sqltbl:map self proc)
  (map (lambda (row)
         (proc (sqltbl:vector->hash self row))) (sqltbl:tbl-get-rows self)))
   
)

(
; Your egg's license:
(license "LGPL")

; Pick one from the list of categories (see below) for your egg and enter it
; here.
(category misc)

; A list of eggs mpeg3 depends on.  If none, you can omit this declaration
; altogether. If you are making an egg for chicken 3 and you need to use
; procedures from the `files' unit, be sure to include the `files' egg in the
; `needs' section (chicken versions < 3.4.0 don't provide the `files' unit).
; `depends' is an alias to `needs'.
(needs srfi-69)

; A list of eggs required for TESTING ONLY.  See the `Tests' section.
(test-depends test)

(author "Matt Welland")
(synopsis "Primitive argument processor."))

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

(use stmlcommon cookie misc-stml formdat session sqltbl keystore)

;; (declare (uses misc-stml))
(use regex)

;; 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: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:dblquote  . args)
  (let* ((inputs (s:extract args))
         (data   (caar inputs))
         (params (s:process-params (cadr inputs))))
    (conc "&quot;" data "&quot;")))

(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 &nbsp; otherwise
(define (s:nbsp str)
  (if (string-match "^\\s*$" str)
      "&nbsp;"
      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-get-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) #\ ) (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))))
           

)

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

;;;; margs.setup

;; compile the code into a dynamically loadable shared object
;; (will generate margs.so)
;; (compile -s margs.scm)

;; Install as extension library
(standard-extension 'cookie       "0.5")
(standard-extension 'misc-stml    "0.5") ;; moved to stmlcommon.scm
(standard-extension 'html-filter  "0.5")
(standard-extension 'formdat      "0.5")
(standard-extension 'session      "0.5")
(standard-extension 'setup        "0.5")
(standard-extension 'sqltbl       "0.5")
(standard-extension 'keystore     "0.5")
(standard-extension 'stmlcommon   "0.5")
(standard-extension 'stml2        "0.5")

;; (install-extension 'stml "stml.so")

;; Copyright 2007-2011, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

;; (require-extension syntax-case)
;; (declare (run-time-macros))

(module stmlcommon
    *

(import  chicken scheme data-structures extras srfi-13 ports )

(use cookie misc-stml formdat session sqltbl keystore)

(include "requirements.scm")

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

(define (stml:cgi-session session)
  (session:initialize session)
  (session:setup session)
  (session:get-vars session)

  (sdat-set-log-port! session ;; (current-error-port))

	 ;; 	   (get-environment-variables))
	 ;; (print "</table>")
	 (print "</body></html>")))
   (if proc (proc s:session) (stml:cgi-session s:session))
 ;; (raise-error)
 ;; (exit)
   ))

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

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

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

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

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


)