Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -4,42 +4,53 @@ # 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 +# +# 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 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) Index: doc/howto.txt ================================================================== --- doc/howto.txt +++ doc/howto.txt @@ -1,25 +1,35 @@ 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 + +(s:get-page-params) => '("p1" "p2") + -====================================================================== -1. Create a link. +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 @@ -31,42 +41,46 @@ 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" ;; . '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) @@ -73,12 +87,13 @@ 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: @@ -85,12 +100,26 @@ (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) @@ -100,12 +129,13 @@ 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")) @@ -112,8 +142,5 @@ (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. - DELETED doc/stml-manual.odt Index: doc/stml-manual.odt ================================================================== --- doc/stml-manual.odt +++ /dev/null cannot compute difference between binary files Index: formdat.scm ================================================================== --- formdat.scm +++ formdat.scm @@ -33,11 +33,17 @@ (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)) Index: misc-stml.scm ================================================================== --- misc-stml.scm +++ misc-stml.scm @@ -131,19 +131,24 @@ ;; (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))) - (string=? pcrypted crypted))) + (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" @@ -170,15 +175,16 @@ (s:log res) (loop (read-line p)(cons (list l "
") 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)))) + (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)))) ;; anything except a list is converted to a string!!! (define (s:any->string val) (cond ((string? val) val) Index: requirements.scm.template ================================================================== --- requirements.scm.template +++ requirements.scm.template @@ -1,11 +1,11 @@ ;; 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) ADDED rollup-pages.scm Index: rollup-pages.scm ================================================================== --- /dev/null +++ rollup-pages.scm @@ -0,0 +1,49 @@ +(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)))) + + + Index: session.scm ================================================================== --- session.scm +++ session.scm @@ -24,11 +24,11 @@ ;; 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)) @@ -59,10 +59,15 @@ (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)) @@ -92,45 +97,17 @@ (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 () -;; (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 -;; 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 -;; 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)) +(define (sdat-set-shared-hash! vec val)(vector-set! vec 33 val)) + +(define (session:set-shared! vec varname val) + (hash-table-set! (vector-ref vec 33) varname val)) + +;; The global session +(define s:session (make-sdat)) ;; 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 @@ -180,11 +157,15 @@ ;; (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) @@ -193,10 +174,13 @@ (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"))) @@ -205,10 +189,11 @@ ;; (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) @@ -450,17 +435,17 @@ ;; 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))) @@ -604,93 +589,87 @@ ((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 ... -(define (session:call-parts self page parts) +;; page-dir-style is: +;; 'stored => stored in executable +;; 'flat => pages flat directory +;; 'dir => directory tree pages//{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 #!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 - (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 - (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) - (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) - (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 () - ;; (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))) - ;;(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 "

Page not found " page "

")))) - -;;(define (session:call self page) -;; (session:call-parts self page 'both)) + (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 + (dir (string-append (sdat-get-sroot self) + (if dir-style + (conc "/pages/") + (conc "/pages/" page))))) + (case dir-style + ;; 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) + (file-exists? scm-file)))) + (if src-file + (begin + (load src-file) + ((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 "

Page not found " page "

")))) + ;; 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)) + ;; (session:process-file view-file)) + ;; (list "

Page not found " page "

"))) + ((dir) "ERROR: dir style not yet re-implemented") + (else + (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:model-path self model) - (string-append (sdat-get-sroot self) "/models/" model ".scm")) +;; (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:pp-formdat self) (let ((dat (formdat:all->strings (sdat-get-formdat self)))) (string-intersperse dat "
"))) @@ -751,10 +730,20 @@ (formdat:get formdat key) (begin (session:log self "ERROR: formdat: " formdat " is not of class ") #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 ") + #f))))) (define (session:run-actions self) (let* ((action (session:get-param self 'action)) (page (sdat-get-page self))) ;; (print "action=" action " page=" page) Index: setup.scm ================================================================== --- setup.scm +++ setup.scm @@ -10,14 +10,10 @@ (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) @@ -24,17 +20,13 @@ (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) @@ -93,18 +85,41 @@ ;; 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) ADDED stml.meta Index: stml.meta ================================================================== --- /dev/null +++ stml.meta @@ -0,0 +1,20 @@ +( +; 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.")) Index: stml.scm ================================================================== --- stml.scm +++ stml.scm @@ -64,10 +64,12 @@ (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)) @@ -87,10 +89,11 @@ (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)))) ADDED stml.setup Index: stml.setup ================================================================== --- /dev/null +++ stml.setup @@ -0,0 +1,18 @@ +;; 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") + ADDED stmlcommon.scm Index: stmlcommon.scm ================================================================== --- /dev/null +++ stmlcommon.scm @@ -0,0 +1,65 @@ +;; 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 " 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 "
") + (print "") + (for-each (lambda (var) + (print "")) + (get-environment-variables)) + (print "
" (car var) "" (cdr var) "
") + (print "")) + + (if proc (proc s:session) (stml:cgi-session s:session)) + ;; (raise-error) + ;; (exit) + )) ADDED stmlmodule.scm Index: stmlmodule.scm ================================================================== --- /dev/null +++ stmlmodule.scm @@ -0,0 +1,14 @@ +;; 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") + Index: stmlrun.scm ================================================================== --- stmlrun.scm +++ stmlrun.scm @@ -10,49 +10,9 @@ ;; PURPOSE. ;; (require-extension syntax-case) ;; (declare (run-time-macros)) -(handle-exceptions - exn - (begin - (print "Content-type: text/html") - (print "") - (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 "
") - (print "") - (for-each (lambda (var) - (print "")) - (get-environment-variables)) - (print "
" (car var) "" (cdr var) "
") - (print "")) - (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)) - - (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) - ) +;; (include "stmlcommon.scm") +(require-library stml) + +(stml:main #f) Index: sugar.scm ================================================================== --- sugar.scm +++ sugar.scm @@ -22,18 +22,83 @@ ;; (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)])) - -(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)))) - +;; 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 # 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)))) +;;