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

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

SRCFILES    = stml.scm misc-stml.scm session.scm sqltbl.scm formdat.scm setup.scm stmlrun.scm keystore.scm html-filter.scm cookie.scm 
SRCFILES    = stml.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 
$(TARGDIR)/stmlrun : stmlrun stml.so
	echo "NOTE: CSC_OPTIONS='-C \"-fPIC\"' make"
	install stmlrun $(TARGDIR)
	chmod a+rx $(TARGDIR)/stmlrun

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

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

stmlrun : $(OFILES) stmlrun.scm requirements.scm
	csc $(OFILES) -o stmlrun
stmlrun : $(OFILES) stmlrun.scm requirements.scm stmlcommon.scm
	csc $(OFILES) stmlrun.scm -o stmlrun

stml.so : stmlmodule.so
	cp stmlmodule.so stml.so

stmlmodule.so : $(OFILES) stmlmodule.scm requirements.scm stmlcommon.scm
	csc $(OFILES) -s stmlmodule.scm

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

Gotchas!
=======

1. All items for a page *must* be part of a list!
All items for a page *must* be part of a list!
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

   OK:     (list (function1 param1)(function2 param2))
   NOT OK: (begin (function1 param1)(function2 param2))


Various components
~~~~~~~~~~~~~~~~~~
==================

The URL:

http://the.domain.com/pagename/p1/p2/p3?param1=value1
======================================================================
1. Create a link.

(s:get-page-params) => '("p1" "p2")

(s:get-param 'param1) => "value1"

Create a link.
~~~~~~~~~~~~~~

(s:null "[" (s:a name 'href 
               (s:link-to (string-append "location/" (string-intersperse p "/") ""))) "] ")))

======================================================================
2. Call current page with new param


Call current page with new param
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

In view.scm:

 (s:center "[" (s:a 'href (s:link-to "polls"
                           'id
                            (begin
                              (poll:poll 'fill-polls)
                              (poll:poll 'get-next-poll)))
                          "Go to the next poll")  "]")

In control.scm:

(let ((poll-id (s:get-param 'id)))
 ;; do stuff based on poll-id

======================================================================
3. Call an action on a specific page

Call an action on a specific page
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

 (s:a 'href (s:link-to "polls" 'id (poll:poll 'get 'id) 
			       'action "poll.edit")
            "Suggest changes to this poll")

 NOT TRUE! This calls fuction poll.edit (should be in control.scm). Parameter set is 'id to a poll num.

======================================================================
4. A complex link example

A complex link example
~~~~~~~~~~~~~~~~~~~~~~

(s:a "Reply" 'href (s:link-to (s:current-page) 
	           'action "discussion.reply" ;; <page>.<action>
	           'reply_to (number->string (hash-table-ref row 'posts.id)) 
	           'id (s:get "discussion.parent_object_id")) "reply")

;; use (s:get-param to get the 'id, or 'reply_to values

======================================================================
5. Get and set a session var

Get and set a session var
~~~~~~~~~~~~~~~~~~~~~~~~~

(s:session-var-get "keyname")
(s:session-var-set! "keyname" "value")

5.1 Page local vars

(s:set! key val)
(s:get key)

======================================================================
6. make a selection drop down

make a selection drop down
~~~~~~~~~~~~~~~~~~~~~~~~~~

In view.scm: 

(s:select '(("World" 0)("Country" 1)("State" 2)("Town/City" 3)) 'name 'scope)

In control.scm:

(let ((scope (s:get-input 'scope)))
  ....

======================================================================
7. Simple error reporting

Simple error reporting
~~~~~~~~~~~~~~~~~~~~~~

In control.scm:
(s:set-err "You must provide an email address")

In view.scm:
(s:get-err s:err-font)

Or:
(s:get-err (lambda (x)(s:err-font x (s:br))))

======================================================================
8. Misc useful stuff

Sharing data between pages
~~~~~~~~~~~~~~~~~~~~~~~~~~

NOTE: This data is *not* preserved between cgi calls.

;; In first page called
(s:shared-set! "somekey" somevalue)

;; In a page called later
(let ((dat (s:shared-get "somekey")))
  ( .... ))


Misc useful stuff
~~~~~~~~~~~~~~~~~

  i. Lazy/safe string->number 

(s:any->number val)

  ii. Random string

(session:make-rand-string len)

 iii. string to number for pgint
 
(s:any->pgint val)

======================================================================
9. Forms and input

Forms and input
~~~~~~~~~~~~~~~

(s:form 'action "login.login" 'method "post"
   (s:input-preserve 'type "text" 'name "email-address" 'size "16" 'maxlength "30")
   (s:input 'type "submit"   'name "form-name" 'value "login"))

(s:get-input 'email-address)

To preserve the input simply do a set of the value on the 'name field:
(s:set! "email-address" "matt@kiatoa.com")

======================================================================
10. 

STML User Manual
================
Matt Welland <matt@kiatoa.com>
v1.0, 2012-6

FriendMaker is a minimalistic tool to help bring like-minded people together on sites such Second Life.
NOT DONE YET! :( sorry.

:numbered!:
[abstract]
Example Abstract
----------------

Yada about stml

(define-inline (formdat:formdat-get-data   vec)    (vector-ref  vec 0))
(define-inline (formdat:formdat-set-data!  vec val)(vector-set! vec 0 val))

(define (formdat:initialize self)
  (formdat:formdat-set-data! self (make-hash-table)))

(define (formdat:get self key)
  (hash-table-ref/default (formdat:formdat-get-data self) key #f))
  (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

;; openssl passwd -crypt -salt xx password
;;
(define (s:crypt-passwd pw s)
  (let* ((salt (if s s (session:make-rand-string 2)))
	 (inp (open-input-pipe 
               ;;(string-append "echo " pw " | mkpasswd -S " salt " -s")))
	       (conc "mkpasswd " pw " " salt)))
	       ;; (conc "mkpasswd " pw " " salt)
	       (conc "openssl passwd -crypt -salt " salt " " pw)
               ))
         (res (read-line inp)))
    (close-input-port inp)
    res))

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

		       (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))
  (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))))
      (begin (s:error-page "Bad URI" (let ((ref (get-environment-variable "HTTP_REFERER")))
				       (if ref
					   (list "referred from" ref)
					   "")))
	     (exit))))

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

;; choose your db interface as appropriate
(require-extension sqlite3)
(import (prefix sqlite3 sqlite3:))

(require-extension postgresql)
(import (prefix postgresql pg:))
;; (require-extension postgresql)
;; (import (prefix postgresql pg:))

;; (require-extension cgi-util)
;; (require-extension cookie)
(use posix)
;; (require-extension proplist)
(use regex)
(use srfi-1) 

(use regex posix srfi-69 srfi-1)

(define extract-rx (regexp "pages\\/(.*)_(view|ctrl).scm"))

(define (print-page-wrapper lookup page)
  (print "(define (pages:" page " session db shared)")
  (if (hash-table-ref/default lookup (conc page "_ctrl") #f)
      (print "(include \"pages/" page "_ctrl.scm\")"))
  (if (hash-table-ref/default lookup (conc page "_view") #f)
      (print "(include \"pages/" page "_view.scm\")"))
  (print ")\n"))

(let* ((views  (glob "pages/*_view.scm"))
       (ctrls  (glob "pages/*_ctrl.scm"))
       (all    (append views ctrls))
       (lookup (make-hash-table))
       (pages  (delete-duplicates
		(map (lambda (x)
		       (let* ((res  (string-match extract-rx x))
			      (page (cadr res))
			      (type (caddr res)))
			 (hash-table-set! lookup (conc page "_" type) #t)
			 (cadr res)))
		     all))))
  (if (null? all)(begin (print "No page files matching pages/*_(view|ctrl).scm")(exit)))
  (print "Pages: " pages)
  ;; first the individual rollup wrappers (used by the dynamic load)
  (for-each 
   (lambda (page)
     (let ((pagefile  (conc "pages/" page ".scm")))
       (print "page " page " ")
       (if (not (file-exists? pagefile))
	   (begin
	     (with-output-to-file pagefile
	       (lambda ()
		 (print-page-wrapper lookup page)))
	     (print " created"))
	   (print " already created"))))
   pages)
  ;; then the monolithic rollup wrapper (used in compiling the single-executable)
  (with-output-to-file "all_pages.scm"
    (lambda ()
      (for-each
       (lambda (page)
	 (print-page-wrapper lookup page))
       pages))))


  

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

;; make-vector-record session session dbtype dbinit conn params path-params session-key session-id domain toppage page curr-page content-type page-type sroot twikidir pagedat alt-page-dat pagevars pagevars-before sessionvars sessionvars-before globalvars globalvars-before logpt formdat request-method session-cookie curr-err log-port logfile seen-pages page-dir-style debugmode
(define (make-sdat)(make-vector 33))
(define (make-sdat)(make-vector 34))
(define (sdat-get-dbtype               vec)    (vector-ref  vec 0))
(define (sdat-get-dbinit               vec)    (vector-ref  vec 1))
(define (sdat-get-conn                 vec)    (vector-ref  vec 2))
(define (sdat-get-pgconn               vec)    (vector-ref (vector-ref vec 2) 1))
(define (sdat-get-params               vec)    (vector-ref  vec 3))
(define (sdat-get-path-params          vec)    (vector-ref  vec 4))
(define (sdat-get-session-key          vec)    (vector-ref  vec 5))

(define (sdat-get-session-cookie       vec)    (vector-ref  vec 26))
(define (sdat-get-curr-err             vec)    (vector-ref  vec 27))
(define (sdat-get-log-port             vec)    (vector-ref  vec 28))
(define (sdat-get-logfile              vec)    (vector-ref  vec 29))
(define (sdat-get-seen-pages           vec)    (vector-ref  vec 30))
(define (sdat-get-page-dir-style       vec)    (vector-ref  vec 31))
(define (sdat-get-debugmode            vec)    (vector-ref  vec 32))
(define (sdat-get-shared-hash          vec)    (vector-ref  vec 33))

(define (session:get-shared vec varname)
  (hash-table-ref/default (vector-ref vec 33) varname #f))

(define (sdat-set-dbtype!              vec val)(vector-set! vec 0 val))
(define (sdat-set-dbinit!              vec val)(vector-set! vec 1 val))
(define (sdat-set-conn!                vec val)(vector-set! vec 2 val))
(define (sdat-set-params!              vec val)(vector-set! vec 3 val))
(define (sdat-set-path-params!         vec val)(vector-set! vec 4 val))
(define (sdat-set-session-key!         vec val)(vector-set! vec 5 val))
(define (sdat-set-session-id!          vec val)(vector-set! vec 6 val))

(define (sdat-set-session-cookie!      vec val)(vector-set! vec 26 val))
(define (sdat-set-curr-err!            vec val)(vector-set! vec 27 val))
(define (sdat-set-log-port!            vec val)(vector-set! vec 28 val))
(define (sdat-set-logfile!             vec val)(vector-set! vec 29 val))
(define (sdat-set-seen-pages!          vec val)(vector-set! vec 30 val))
(define (sdat-set-page-dir-style!      vec val)(vector-set! vec 31 val))
(define (sdat-set-debugmode!           vec val)(vector-set! vec 32 val))
(define (sdat-set-shared-hash!         vec val)(vector-set! vec 33 val))

;; (define-class <session> ()
;;   (dbtype       ;; 'pg or 'sqlite3
;;    dbinit
;;    conn
;;    params       ;; params from the key=val&key1=val2 string
;;    path-params  ;; remaining params from the path
;;    session-key
;;    session-id
(define (session:set-shared! vec varname val)
;;    domain
;;    toppage      ;; defaults to "index" - override in .stml.config if desired
;;    page         ;; the page name - defaults to home
;;    curr-page    ;; the current page being evaluated
  (hash-table-set! (vector-ref vec 33) varname val))

;;    content-type ;; the default content type is text/html, override to deliver other stuff
;;    page-type    ;; use in conjunction with content-type to deliver other payloads
;;    sroot
;;    twikidir     ;; location for twikis - needs to be fully writable by web server
;;    pagedat
;;    alt-page-dat
;;    pagevars     ;; session vars specific to this page
;;    pagevars-before
;;    sessionvars  ;; session vars visible to all pages
;;    sessionvars-before
;; The global session
;;    globalvars   ;; global vars visible to all sessions
;;    globalvars-before
;;    logpt
;;    formdat
(define s:session (make-sdat))
;;    request-method
;;    session-cookie
;;    curr-err
;;    log-port
;;    logfile
;;    seen-pages
;;    page-dir-style  ;; #t = new style, #f = old style
;;    debugmode))

;; SPLIT INTO STRAIGHT FORWARD INIT AND COMPLEX INIT
(define (session:initialize self)
  (sdat-set-dbtype! self      'pg)
  (sdat-set-page! self        "home")        ;; these are defaults
  (sdat-set-curr-page! self   "home")
  (sdat-set-content-type! self "Content-type: text/html; charset=iso-8859-1\n\n")

    (if debugmode (sdat-set-debugmode! self debugmode))
    (sdat-set-page-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-set-shared-hash! self (make-hash-table))
  )

;; Used for the strangely inconsistent handling of the config file. A better way is needed.
;;
;;   (let ((dbtype (sdat-get-dbtype self)))
;;     (print "dbtype: " dbtype)
;;     (sdat-set-dbtype! self (eval dbtype))))

(define (session:setup self)
  (let ((dbtype    (sdat-get-dbtype self))
	(debugmode (sdat-get-debugmode self))
	(dbinit    (eval (sdat-get-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-set-conn! self (dbi:open dbtype dbinit))
    (set! *db* (sdat-get-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

(define (session:page-get self key)
  (hash-table-ref/default (sdat-get-pagevars self) key #f))

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

;; delete a session var for a specified page
;;
(define (session:del! self page key)
  (let ((ht (session:get-page-hash self page)))
    (hash-table-delete! ht key)))
    (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-get-session-id self)))
    (if (not session-id)
	(err:log "ERROR: No session id in session object! session:get-vars")

					(s:sqlparam ins-query session-id page key master-value)))
		     (else (err:log "Shouldn't get here")))))
		all-keys))) ;; process all keys
	   (list "*sessionvars*" "*globalvars*" page-name))))))

;; (pg:sql-null-object? element)
(define (session:read-config self)
  (let* ((cgi-path (pathname-directory (car (argv))))
  (let ((name (string-append "." (pathname-file (car (argv))) ".config")))
         (name     (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))))

       (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
;;  'view     => load view only
;;  'control  => load control only
(define (session:call-parts self page parts)
(define (session:call-parts self page #!key (parts 'both))
  (sdat-set-curr-page! self page)
  ;; (session:log self "page-dir-style: " (sdat-get-page-dir-style self))
  (let* ((dir-style ;; (equal? (sdat-get-page-dir-style self) "onedir")) ;; flag #t for onedir, #f for old style
  (let* ((dir-style    (sdat-get-page-dir-style self));; (equal? (sdat-get-page-dir-style self) "onedir")) ;; flag #t for onedir, #f for old style
	  (sdat-get-page-dir-style self))
	 (dir     (string-append (sdat-get-sroot self) 
				 (if dir-style 
				     (conc "/pages/")
				     (conc "/pages/" page))))
	 (control (string-append dir (if dir-style 
	 (dir          (string-append (sdat-get-sroot self) 
				      (if dir-style 
					  (conc "/pages/")
					  (conc "/pages/" page)))))
    (case dir-style
					 (conc page "_ctrl.scm")
					 "/control.scm")))
	 (view    (string-append dir (if dir-style 
					 (conc page "_view.scm")
					 "/view.scm")))
	 (load-view    (and (file-exists? view)
      ;; NB// Stored always loads both control and view
      ((stored)
       ((eval (string->symbol (conc "pages:" page))) 
	self                         ;; the session
	(sdat-get-conn self)         ;; the db connection
	(sdat-get-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)
			    (or (eq? parts 'both)(eq? parts 'view))))
	 (load-control (and (file-exists? control)
			    (file-exists? scm-file))))
			    (or (eq? parts 'both)(eq? parts 'control))))
	 (view-dat   '()))
    ;; (session:log self "dir-style: " dir-style)
 ;;   (sugar "/home/matt/kiatoa/stml/sugar.scm" ))
    ;; (print "dir=" dir " control=" control " view=" view " load-view=" load-view " load=control=" load-control)
    (if load-control
	(begin
	  (load control)
	 (if src-file
	     (begin
	       (load src-file)
	  (session:set-called! self page)))
    ;; move this to where it gets exectuted only once
    ;;
    ;;(s:log "s:b yields " (s:b "blah"))
    (if load-view
	;; option one:
	;;
	;; (let ((inp (open-input-string 
	;; 	    (files-read->string "/home/matt/kiatoa/stml/sugar.scm" 
	;; 				view))))
	;;   (map 
	;;    (lambda (x)
	;;      (cond
	;;       ((list? x) x)
	;;       ((string? x) x)
	;;       (else '())))
	;;    (port-map eval (lambda ()
	       ((eval (string->symbol (conc "pages:" page))) 
		self                         ;; the session
		(sdat-get-conn self)         ;; the db connection
		(sdat-get-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))
	;; 		 (read inp)))))
	;;
	;; option two:
	;;
	(let* (;; (inps (map open-input-file (list view))) ;; sugar view)))
	       (p    (open-input-file view)) ;; (apply make-concatenated-port inps))
	       (dat  (process-port p)))
       ;;  	 (session:process-file view-file))
		;;(map 
		;;      (lambda (x)
		;;	(cond
		;;	 ((list? x) x)
		;;	 ((string? x) x)
		;;	 (else '())))
		;;      (port-map eval (lambda ()(read p))))))
	  ;; (map close-input-port inps)
	  (close-input-port p)
	  dat)
	(list "<p>Page not found " page " </p>"))))

;;(define (session:call self page)
       ;;       (list "<p>Page not found " page " </p>")))
      ((dir) "ERROR:  dir style not yet re-implemented")
      (else
;;  (session:call-parts self page 'both))
       (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 ((model.scm (string-append (sdat-get-sroot self) "/models/" model ".scm"))
	(model.so  (string-append (sdat-get-sroot self) "/models/" model ".so")))
    (if (file-exists? model.so)
	(load model.so)
	(if (file-exists? model.scm)
	    (load model.scm)
	    (s:log "ERROR: model " model.scm " not found")))))
;; (define (session:load-model self model)
;;   (let ((model.scm (string-append (sdat-get-sroot self) "/models/" model ".scm"))
;; 	(model.so  (string-append (sdat-get-sroot self) "/models/" model ".so")))
;;     (if (file-exists? model.so)
;; 	(load model.so)
;; 	(if (file-exists? model.scm)
;; 	    (load model.scm)
;; 	    (s:log "ERROR: model " model.scm " not found")))))

(define (session:model-path self model)
  (string-append (sdat-get-sroot self) "/models/" model ".scm"))
;; (define (session:model-path self model)
;;   (string-append (sdat-get-sroot self) "/models/" model ".scm"))

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

(define (session:param->string params)
  ;; (err:log "params=" params)

	(if (or (string? key)(number? key)(symbol? key))
	    (if (and (vector? formdat)(eq? (vector-length formdat) 1)(hash-table? (vector-ref formdat 0)))
		(formdat:get formdat key)
		(begin
		  (session:log self "ERROR: formdat: " formdat " is not of class <formdat>")
		  #f))
	    (session:log self "ERROR: bad key " key)))))

;; This one will get the first value found regardless of form
(define (session:get-input-keys self)
  (let* ((formdat (sdat-get-formdat self)))
    (if (not formdat) #f
	(if (and (vector? formdat)(eq? (vector-length formdat) 1)(hash-table? (vector-ref formdat 0)))
	    (formdat:keys formdat)
	    (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))
	 (page      (sdat-get-page self)))
    ;; (print "action=" action " page=" page)
    (if action
	(let ((action-lst  (string-split action ".")))

;;  PURPOSE.

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

;; 
(define s:session (make-sdat))
(session:initialize s:session)

;; use this for getting data from page to page when scope and evals
;; get in the way
(define s:local-vars (make-hash-table))

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

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

(session:setup s:session)

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

(session:get-vars s:session)

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

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

  (session:del! s:session "*sessionvars*" key))

;; utility to get all vars as hash table
(define (s:session-get-sessionvars)
  (sdat-get-sessionvars s:session))

;; inputs
;;
(define (s:get-input key)
  (session:get-input s:session key))

(define (s:get-input-keys)
  (session:get-input-keys s:session))

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

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

;; share data between pages calls. NOTE: This is not persistent
;; between cgi calls. Use sessionvars for that.
;;
(define (s:shared-hash)
  (sdat-get-shared-hash s:session))

(define (s:shared-set! key val)
  (hash-table-set! (sdat-get-shared-hash s:session) key val))

;; What to return when no value for key?
;;
(define (s:shared-get key)
  (hash-table-ref/default (sdat-get-shared-hash s:session) key #f))

;; http://foo.bar.com/pagename/p1/p2 => '("p1" "p2")
;;
(define (s:get-page-params)
  (sdat-get-page-params s:session))

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

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

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

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

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

(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))
		      (open-output-file (sdat-get-logfile session) #:append))
  (s:validate-inputs)
  (session:run-actions session)
  (sdat-set-pagedat! session
		     (append (sdat-get-pagedat session)
			     (s:call (sdat-get-toppage session))))
  (if (eq? (sdat-get-page-type session) 'html) ;; default is html. 
      (session:cgi-out session)
      (session:alt-out session))
  (session:save-vars session)
  (session:close session))

(define (stml:main proc)
  (handle-exceptions
   exn   
   (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>"))
   
   (if proc (proc s:session) (stml:cgi-session s:session))
 ;; (raise-error)
 ;; (exit)
   ))

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

(include "stmlcommon.scm")

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

(handle-exceptions
 exn   
 (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>"))
 (include "requirements.scm")
;; (include "stmlcommon.scm")
 (declare (uses cookie))
 (declare (uses html-filter))
 (declare (uses misc-stml))
 (declare (uses formdat))
 (declare (uses stml))
(require-library stml)
 (declare (uses session))
 (declare (uses setup)) ;; s:session gets created here
 (declare (uses sqltbl))
 (declare (uses keystore))
 

 (sdat-set-log-port! s:session ;; (current-error-port))
 		     (open-output-file (sdat-get-logfile s:session) #:append))
 (s:validate-inputs)
 (session:run-actions s:session)
 (sdat-set-pagedat! s:session
 		    (append (sdat-get-pagedat s:session)
 			    (s:call (sdat-get-toppage s:session))))
 (if (eq? (sdat-get-page-type s:session) 'html) ;; default is html. 
     (session:cgi-out s:session)
     (session:alt-out s:session))
 (session:save-vars s:session)
 (session:close s:session)
 ;; (raise-error)
 ;; (exit)
 )

(stml:main #f)

;;     [(_ 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-macro (s:if-param varname . dat)
  (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))))

;; (define-macro (s:if-param varname . dat)
;;   (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))))
;;