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


)