;; 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))
(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
(if (sdat-get-debugmode s:session)
(begin
(print "Content-type: text/html")
(print "")
(print "<html> <head> <title>EXCEPTION</title> </head> <body>")
(print " QUERY_STRING is: <b> " (get-environment-variable "QUERY_STRING") " </b> <br>")
(print "<pre>")
;; (print " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
(print-error-message exn)
(print-call-chain)
(print "</pre>")
(print "<table>")
(for-each (lambda (var)
(print "<tr><td>" (car var) "</td><td>" (cdr var) "</td></tr>"))
(get-environment-variables))
(print "</table>")
(print "</body></html>"))
(begin
(with-output-to-file (conc "/tmp/stml-crash-" (current-process-id) ".log")
(lambda ()
(print "EXCEPTION")
(print " QUERY_STRING is: " (get-environment-variable "QUERY_STRING") )
(print "")
;; (print " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
(print-error-message exn)
(print-call-chain)
(print "")
(for-each (lambda (var)
(print (car var) "\t" (cdr var)))
(get-environment-variables))))
;; return something useful to the user
(print "Content-type: text/html")
(print "")
(print "<html> <head> <title>EXCEPTION</title> </head> <body>")
(print "<h1>CRASH!</h1>")
(print " Please notify support at " (sdat-get-domain s:session) " that the error log is stml-crash-" (current-process-id) ".log</b> <br>")
;; (print "<pre>")
;; ;; (print " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
;; ;; (print-error-message exn)
;; ;; (print-call-chain)
;; (print "</pre>")
;; (print "<table>")
;; (for-each (lambda (var)
;; (print "<tr><td>" (car var) "</td><td>" (cdr var) "</td></tr>"))
;; (get-environment-variables))
;; (print "</table>")
(print "</body></html>")))
(if proc (proc s:session) (stml:cgi-session s:session))
;; (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))
)