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

include install.cfg

SRCFILES    = stml.scm misc-stml.scm session.scm sqltbl.scm formdat.scm setup.scm stmlrun.scm keystore.scm html-filter.scm cookie.scm 
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
	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)

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

(use regex posix srfi-69 srfi-1)

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

(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)
  (with-output-to-file "all_pages.scm"
    (lambda ()
      (for-each (lambda (page)
		  (print "(define (pages:" page ")")
		  (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"))
		pages))))


  

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

;; (define-class <session> ()
;;   (dbtype       ;; 'pg or 'sqlite3
;;    dbinit
;;    conn
;;    params       ;; params from the key=val&key1=val2 string
;;    path-params  ;; remaining params from the path
;;    session-key
;;    session-id
;; The global session
;;    domain
;;    toppage      ;; defaults to "index" - override in .stml.config if desired
;;    page         ;; the page name - defaults to home
;;    curr-page    ;; the current page being evaluated
;;    content-type ;; the default content type is text/html, override to deliver other stuff
;;    page-type    ;; use in conjunction with content-type to deliver other payloads
;;    sroot
;;    twikidir     ;; location for twikis - needs to be fully writable by web server
;;    pagedat
(define s:session (make-sdat))
;;    alt-page-dat
;;    pagevars     ;; session vars specific to this page
;;    pagevars-before
;;    sessionvars  ;; session vars visible to all pages
;;    sessionvars-before
;;    globalvars   ;; global vars visible to all sessions
;;    globalvars-before
;;    logpt
;;    formdat
;;    request-method
;;    session-cookie
;;    curr-err
;;    log-port
;;    logfile
;;    seen-pages
;;    page-dir-style  ;; #t = new style, #f = old style
;;    debugmode))

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

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

       (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
  (session:log self "page-dir-style: " (sdat-get-page-dir-style self))
  (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 
      ;; NB// Stored always loads both control and view
      ((stored)((eval (string->symbol (conc "pages:" page)))))
					 (conc page "_view.scm")
					 "/view.scm")))
	 (load-view    (and (file-exists? view)
			    (or (eq? parts 'both)(eq? parts 'view))))
	 (load-control (and (file-exists? control)
			    (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)
      ((dir)   
       ;; first the control
	  (session:set-called! self page)))
    ;; move this to where it gets exectuted only once
    ;;
    ;;(s:log "s:b yields " (s:b "blah"))
    (if load-view
	;; option one:
	;;
	;; (let ((inp (open-input-string 
	;; 	    (files-read->string "/home/matt/kiatoa/stml/sugar.scm" 
	;; 				view))))
	;;   (map 
       (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
	;;    (lambda (x)
	;;      (cond
	;;       ((list? x) x)
	;;       ((string? x) x)
	;;       (else '())))
	       (session:set-called! self page)
	       (load control-file)))
	 (if (file-exists? view-file)
	     (if (not (eq? parts 'control))
	;;    (port-map eval (lambda ()
	;; 		 (read inp)))))
	;;
	;; option two:
	;;
	(let* (;; (inps (map open-input-file (list view))) ;; sugar view)))
	       (p    (open-input-file view)) ;; (apply make-concatenated-port inps))
	       (dat  (process-port p)))
		 (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>"))))
      ((flat))
      (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)

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

(
; 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-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)
(stml:main #f)
 ;; (exit)
 )