" use_html: #t attach-files-list: '( "/Users/bb/Downloads/wdmycloud-manual-4779-705103.pdf" ) )
+
+;(launch-repl)
+(test-exit)
ADDED ducttape/test_example.scm
Index: ducttape/test_example.scm
==================================================================
--- /dev/null
+++ ducttape/test_example.scm
@@ -0,0 +1,3 @@
+(use ducttape-lib)
+
+(inote "Hello world")
ADDED ducttape/useargs-example.scm
Index: ducttape/useargs-example.scm
==================================================================
--- /dev/null
+++ ducttape/useargs-example.scm
@@ -0,0 +1,19 @@
+(use ducttape-lib)
+
+(let (
+ (customers (skim-cmdline-opts-withargs-by-regex "--cust(omer)?"))
+ (magicmode (skim-cmdline-opts-noarg-by-regex "--magic"))
+ )
+ (print "your customers are " customers)
+ (if (null? magicmode)
+ (print "no unicorns for you")
+ (print "magic!")
+ )
+ )
+
+(idbg "hello")
+(idbg "hello2" 2)
+(idbg "hello2" 3)
+(inote "note")
+(iwarn "warn")
+(ierr "err")
ADDED ducttape/workweekdate.scm
Index: ducttape/workweekdate.scm
==================================================================
--- /dev/null
+++ ducttape/workweekdate.scm
@@ -0,0 +1,193 @@
+(use srfi-19)
+(use test)
+;;(use format)
+(use regex)
+;(declare (unit wwdate))
+;; utility procedures to convert among
+;; different ways to express date (wwdate, seconds since epoch, isodate)
+;;
+;; samples:
+;; isodate -> "2016-01-01"
+;; wwdate -> "16ww01.5"
+;; seconds -> 1451631600
+
+;; procedures provided:
+;; ====================
+;; seconds->isodate
+;; seconds->wwdate
+;;
+;; isodate->seconds
+;; isodate->wwdate
+;;
+;; wwdate->seconds
+;; wwdate->isodate
+
+;; srfi-19 used extensively; this doc is better tha the eggref:
+;; http://srfi.schemers.org/srfi-19/srfi-19.html
+
+;; Author: brandon.j.barclay@intel.com 16ww18.6
+
+(define (date->seconds date)
+ (inexact->exact
+ (string->number
+ (date->string date "~s"))))
+
+(define (seconds->isodate seconds)
+ (let* ((date (seconds->date seconds))
+ (result (date->string date "~Y-~m-~d")))
+ result))
+
+(define (isodate->seconds isodate)
+ "Takes a string input of the form 'YY-MM-DD' or 'YYYY-MM-DD' and returns epoch time; for YY, assume after Y2K"
+ (let* ((numlist (map string->number (string-split isodate "-")))
+ (raw-year (car numlist))
+ (year (if (< raw-year 100) (+ raw-year 2000) raw-year))
+ (month (list-ref numlist 1))
+ (day (list-ref numlist 2))
+ (date (make-date 0 0 0 0 day month year))
+ (seconds (date->seconds date)))
+
+ seconds))
+
+;; adapted from perl Intel::WorkWeek perl module
+;; workweek year consists of numbered weeks starting from week 1
+;; days of week are numbered starting from 0 on sunday
+;; weeks begin on sunday- day number 0 and end saturday- day 6
+;; week 1 is defined as the week containing jan 1 of the year
+;; workweek year does not match calendar year in workweek 1
+;; since workweek 1 contains jan1 and workweek begins sunday,
+;; days prior to jan1 in workweek 1 belong to the next workweek year
+(define (seconds->wwdate-values seconds)
+ (define (date-difference->seconds d1 d2)
+ (- (date->seconds d1) (date->seconds d2)))
+
+ (let* ((thisdate (seconds->date seconds))
+ (thisdow (string->number (date->string thisdate "~w")))
+
+ (year (date-year thisdate))
+ ;; intel workweek 1 begins on sunday of week containing jan1
+ (jan1 (make-date 0 0 0 0 1 1 year))
+ (jan1dow (date-week-day jan1))
+ (ww01 (date-subtract-duration jan1 (seconds->time (* 60 60 24 jan1dow))))
+
+ (ww01_delta_seconds (date-difference->seconds thisdate ww01))
+ (wwnum_initial (inexact->exact (add1 (floor (/ ww01_delta_seconds 24 3600 7) ))))
+
+ ;; we could be in ww1 of next year
+ (this-saturday (seconds->date
+ (+ seconds
+ (* 60 60 24 (- 6 thisdow)))))
+ (this-week-ends-next-year?
+ (> (date-year this-saturday) year))
+ (intelyear
+ (if this-week-ends-next-year?
+ (add1 year)
+ year))
+ (intelweek
+ (if this-week-ends-next-year?
+ 1
+ wwnum_initial)))
+ (values intelyear intelweek thisdow)))
+
+(define (string-leftpad in width pad-char)
+ (let* ((unpadded-str (->string in))
+ (padlen_temp (- width (string-length unpadded-str)))
+ (padlen (if (< padlen_temp 0) 0 padlen_temp))
+ (padding (make-string padlen pad-char)))
+ (conc padding unpadded-str)))
+
+(define (string-rightpad in width pad-char)
+ (let* ((unpadded-str (->string in))
+ (padlen_temp (- width (string-length unpadded-str)))
+ (padlen (if (< padlen_temp 0) 0 padlen_temp))
+ (padding (make-string padlen pad-char)))
+ (conc unpadded-str padding)))
+
+(define (zeropad num width)
+ (string-leftpad num width #\0))
+
+(define (seconds->wwdate seconds)
+
+ (let-values (((intelyear intelweek day-of-week-num)
+ (seconds->wwdate-values seconds)))
+ (let ((intelyear-str
+ (zeropad
+ (->string
+ (if (> intelyear 1999)
+ (- intelyear 2000) intelyear))
+ 2))
+ (intelweek-str
+ (zeropad (->string intelweek) 2))
+ (dow-str (->string day-of-week-num)))
+ (conc intelyear-str "ww" intelweek-str "." dow-str))))
+
+(define (isodate->wwdate isodate)
+ (seconds->wwdate
+ (isodate->seconds isodate)))
+
+(define (wwdate->seconds wwdate)
+ (let ((match (string-match "^(\\d+)ww(\\d+).(\\d)$" wwdate)))
+ (if
+ (not match)
+ #f
+ (let* (
+ (intelyear-raw (string->number (list-ref match 1)))
+ (intelyear (if (< intelyear-raw 100)
+ (+ intelyear-raw 2000)
+ intelyear-raw))
+ (intelww (string->number (list-ref match 2)))
+ (dayofweek (string->number (list-ref match 3)))
+
+ (day-of-seconds (* 60 60 24 ))
+ (week-of-seconds (* day-of-seconds 7))
+
+
+ ;; get seconds at ww1.0
+ (new-years-date (make-date 0 0 0 0 1 1 intelyear))
+ (new-years-seconds
+ (date->seconds new-years-date))
+ (new-years-dayofweek (date-week-day new-years-date))
+ (ww1.0_seconds (- new-years-seconds
+ (* day-of-seconds
+ new-years-dayofweek)))
+ (workweek-adjustment (* week-of-seconds (sub1 intelww)))
+ (weekday-adjustment (* dayofweek day-of-seconds))
+
+ (result (+ ww1.0_seconds workweek-adjustment weekday-adjustment)))
+ result))))
+
+(define (wwdate->isodate wwdate)
+ (seconds->isodate (wwdate->seconds wwdate)))
+
+(define (current-wwdate)
+ (seconds->wwdate (current-seconds)))
+
+(define (current-isodate)
+ (seconds->isodate (current-seconds)))
+
+(define (wwdate-tests)
+ (test-group
+ "date conversion tests"
+ (let ((test-table
+ '(("16ww01.5" . "2016-01-01")
+ ("16ww18.5" . "2016-04-29")
+ ("1999ww33.5" . "1999-08-13")
+ ("16ww18.4" . "2016-04-28")
+ ("16ww18.3" . "2016-04-27")
+ ("13ww01.0" . "2012-12-30")
+ ("13ww52.6" . "2013-12-28")
+ ("16ww53.3" . "2016-12-28"))))
+ (for-each
+ (lambda (test-pair)
+ (let ((wwdate (car test-pair))
+ (isodate (cdr test-pair)))
+ (test
+ (conc "(isodate->wwdate "isodate ") => "wwdate)
+ wwdate
+ (isodate->wwdate isodate))
+
+ (test
+ (conc "(wwdate->isodate "wwdate ") => "isodate)
+ isodate
+ (wwdate->isodate wwdate))))
+ test-table))))
Index: http-transport.scm
==================================================================
--- http-transport.scm
+++ http-transport.scm
@@ -40,11 +40,11 @@
(include "common_records.scm")
(include "db_records.scm")
(include "js-path.scm")
-(require-library stml)
+(import stml2)
(define (http-transport:make-server-url hostport)
(if (not hostport)
#f
(conc "http://" (car hostport) ":" (cadr hostport))))
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -20,22 +20,10 @@
;; (include "megatest-version.scm")
;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)
-(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:)
- readline apropos json http-client directory-utils typed-records
- http-client srfi-18 extras format)
-
-;; Added for csv stuff - will be removed
-;;
-(use sparse-vectors)
-
-(require-library mutils)
-
-;; (use zmq)
-
(declare (uses common))
(declare (uses megatest-version))
(declare (uses margs))
(declare (uses runs))
(declare (uses launch))
@@ -44,27 +32,51 @@
(declare (uses tests))
(declare (uses genexample))
;; (declare (uses daemon))
(declare (uses db))
;; (declare (uses dcommon))
+(declare (uses stml2))
+(declare (uses pkts))
+(declare (uses mutils))
(declare (uses tdb))
(declare (uses mt))
(declare (uses api))
(declare (uses tasks)) ;; only used for debugging.
(declare (uses env))
(declare (uses diff-report))
-(declare (uses ftail))
-(import ftail)
+;; (declare (uses ftail))
+;; (import ftail)
+
+(import stml2 mutils)
+
+;; invoke the imports
+;; (declare (uses mtargs.import))
+;; (declare (uses mtconfigf.import))
+(declare (uses cookie.import))
+(declare (uses stml2.import))
+(declare (uses pkts.import))
(define *db* #f) ;; this is only for the repl, do not use in general!!!!
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "megatest-fossil-hash.scm")
+
+(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:)
+ readline apropos json http-client directory-utils typed-records
+ http-client srfi-18 extras format)
+
+;; Added for csv stuff - will be removed
+;;
+(use sparse-vectors)
+
+(import mutils ducttape-lib stml2)
+
+;; (use zmq)
(define *usage-log-file* #f) ;; put path to file for logging usage in this var in the ~/.megatestrc file
(define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file
;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file
@@ -231,15 +243,14 @@
cmd: keep-html, restore, save, save-remove
-generate-html : create a simple html dashboard for browsing your runs
-generate-html-structure : create a top level html veiw to list targets/runs and a Run view within each run directory.
-list-run-time : list time requered to complete runs. It supports following switches
-run-patt -target-patt -dumpmode
- -list-test-time : list time requered to complete each test in a run. It following following arguments
+ -list-test-time : list time requered to complete each test in a run. It following following arguments
-runname -target -dumpmode
-
-
-
+ -syscheck : do some very basic checks; write access and space in tmp, home, runs, links and
+ is $DISPLAY valid
Diff report
-diff-rep : generate diff report (must include -src-target, -src-runname, -target, -runname
and either -diff-email or -diff-html)
-src-target
@@ -252,12 +263,12 @@
-pathmod path : insert path, i.e. path/runame/itempath/logfile.html
will clear the field if no rundir/testname/itempath/logfile
if it contains forward slashes the path will be converted
to windows style
Getting started
- -create-megatest-area : create a skeleton megatest area. You will be prompted for paths
- -create-test testname : create a skeleton megatest test. You will be prompted for info
+ -create-megatest-area : create a skeleton megatest area. You will be prompted for paths
+ -create-test testname : create a skeleton megatest test. You will be prompted for info
Examples
# Get test path, use '.' to get a single path or a specific path/file pattern
megatest -test-files 'logs/*.log' -target ubuntu/n%/no% -runname w49% -testpatt test_mt%
@@ -436,10 +447,12 @@
"-logging"
"-v" ;; verbose 2, more than normal (normal is 1)
"-q" ;; quiet 0, errors/warnings only
"-diff-rep"
+
+ "-syscheck"
)
args:arg-hash
0))
;; Add args that use remargs here
@@ -2343,17 +2356,26 @@
(let* ((toppath (launch:setup)))
(if (tests:create-html-tree #f)
(debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/page0.html")
(debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html"))
(set! *didsomething* #t)))
+
(if (args:get-arg "-generate-html-structure")
(let* ((toppath (launch:setup)))
;(if (tests:create-html-tree #f)
(if (tests:create-html-summary #f)
(debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/targets.html")
(debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html"))
(set! *didsomething* #t)))
+
+(if (args:get-arg "-syscheck")
+ (begin
+ (mutils:syscheck common:raw-get-remote-host-load
+ server:get-best-guess-address
+ read-config)
+ (set! *didsomething* #t)))
+
;;======================================================================
;; Exit and clean up
;;======================================================================
(if (not *didsomething*)
ADDED mtargs.scm
Index: mtargs.scm
==================================================================
--- /dev/null
+++ mtargs.scm
@@ -0,0 +1,23 @@
+;;======================================================================
+;; Copyright 2019, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+;;======================================================================
+
+(declare (unit mtargs))
+
+(include "mtargs/mtargs.scm")
ADDED mtargs/Makefile
Index: mtargs/Makefile
==================================================================
--- /dev/null
+++ mtargs/Makefile
@@ -0,0 +1,22 @@
+# 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.
+
+# TARGDIR = $(shell csi -e "(print (car \#\#sys\#include-pathnames))(exit)")
+
+all : uptodate.log # $(TARGDIR)/mtargs.so
+
+uptodate.log : mtargs.scm mtargs.setup
+ chicken-install | tee uptodate.log
+
+$(TARGDIR)/mtargs.so : mtargs.so
+ @echo installing to $(TARGDIR)
+ cp mtargs.so $(TARGDIR)
+
+mtargs.so : mtargs.scm
+ csc -s mtargs.scm
ADDED mtargs/mtargs.meta
Index: mtargs/mtargs.meta
==================================================================
--- /dev/null
+++ mtargs/mtargs.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 srfi-1)
+
+; A list of eggs required for TESTING ONLY. See the `Tests' section.
+(test-depends test)
+
+(author "Matt Welland")
+(synopsis "Primitive argument processor."))
ADDED mtargs/mtargs.scm
Index: mtargs/mtargs.scm
==================================================================
--- /dev/null
+++ mtargs/mtargs.scm
@@ -0,0 +1,96 @@
+;; Copyright 2007-2010, Matthew Welland.
+;;
+;; This file is part of mtargs.
+;;
+;; mtargs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; mtargs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with mtargs. If not, see .
+
+
+(module mtargs
+ (
+ arg-hash
+ get-arg
+ get-arg-from
+ usage
+ get-args
+ print-args
+ any-defined?
+ help
+ )
+
+(import scheme chicken data-structures extras posix ports files)
+(use srfi-69 srfi-1)
+
+(define arg-hash (make-hash-table))
+(define help "")
+
+(define (get-arg arg . default)
+ (if (null? default)
+ (hash-table-ref/default arg-hash arg #f)
+ (hash-table-ref/default arg-hash arg (car default))))
+
+(define (any-defined? . args)
+ (not (null? (filter (lambda (x) x)
+ (map get-arg args)))))
+
+;; (define any any-defined?)
+
+(define (get-arg-from ht arg . default)
+ (if (null? default)
+ (hash-table-ref/default ht arg #f)
+ (hash-table-ref/default ht arg (car default))))
+
+(define (usage . args)
+ (if (> (length args) 0)
+ (apply print "ERROR: " args))
+ (if (string? help)
+ (print help)
+ (print "Usage: " (car (argv)) " ... "))
+ (exit 0))
+
+(define (get-args args params switches arg-hash num-needed)
+ (let* ((numtargs (length args))
+ (adj-num-needed (if num-needed (+ num-needed 2) #f)))
+ (if (< numtargs (if adj-num-needed adj-num-needed 2))
+ (if (>= num-needed 1)
+ (usage "No arguments provided")
+ '())
+ (let loop ((arg (cadr args))
+ (tail (cddr args))
+ (remtargs '()))
+ (cond
+ ((member arg params) ;; args with params
+ (if (< (length tail) 1)
+ (usage "param given without argument " arg)
+ (let ((val (car tail))
+ (newtail (cdr tail)))
+ (hash-table-set! arg-hash arg val)
+ (if (null? newtail) remtargs
+ (loop (car newtail)(cdr newtail) remtargs)))))
+ ((member arg switches) ;; args with no params (i.e. switches)
+ (hash-table-set! arg-hash arg #t)
+ (if (null? tail) remtargs
+ (loop (car tail)(cdr tail) remtargs)))
+ (else
+ (if (null? tail)(append remtargs (list arg)) ;; return the non-used args
+ (loop (car tail)(cdr tail)(append remtargs (list arg))))))))
+ ))
+
+(define (print-args remtargs arg-hash)
+ (print "ARGS: " remtargs)
+ (for-each (lambda (arg)
+ (print " " arg " " (hash-table-ref/default arg-hash arg #f)))
+ (hash-table-keys arg-hash)))
+
+
+)
ADDED mtargs/mtargs.setup
Index: mtargs/mtargs.setup
==================================================================
--- /dev/null
+++ mtargs/mtargs.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.
+
+;;;; mtargs.setup
+
+;; compile the code into a dynamically loadable shared object
+;; (will generate mtargs.so)
+(compile -s mtargs.scm)
+
+;; Install as extension library
+(standard-extension 'mtargs "mtargs.so")
+
Index: mtut.scm
==================================================================
--- mtut.scm
+++ mtut.scm
@@ -21,25 +21,25 @@
;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)
(use srfi-1 posix srfi-69 readline ;; regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras)
- srfi-19 srfi-18 extras format pkts regex regex-case
+ srfi-19 srfi-18 extras format regex regex-case
(prefix dbi dbi:)
nanomsg)
(declare (uses common))
(declare (uses megatest-version))
(declare (uses margs))
(declare (uses configf))
;; (declare (uses rmt))
-(use ducttape-lib)
+(import ducttape-lib pkts)
(include "megatest-fossil-hash.scm")
-(require-library stml)
+(import stml2)
;; stuff for the mapper and checker functions
;;
(define *target-mappers* (make-hash-table))
(define *runname-mappers* (make-hash-table))
ADDED mutils.scm
Index: mutils.scm
==================================================================
--- /dev/null
+++ mutils.scm
@@ -0,0 +1,23 @@
+;;======================================================================
+;; Copyright 2019, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+;;======================================================================
+
+(declare (unit mutils))
+
+(include "mutils/mutils.scm")
ADDED mutils/Makefile
Index: mutils/Makefile
==================================================================
--- /dev/null
+++ mutils/Makefile
@@ -0,0 +1,22 @@
+# 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.
+
+# TARGDIR = $(shell csi -e "(print (car \#\#sys\#include-pathnames))(exit)")
+
+all : uptodate.log # $(TARGDIR)/mutils.so
+
+uptodate.log : mutils.scm mutils.setup
+ chicken-setup | tee uptodate.log
+
+$(TARGDIR)/mutils.so : mutils.so
+ @echo installing to $(TARGDIR)
+ cp mutils.so $(TARGDIR)
+
+mutils.so : mutils.scm
+ csc -s mutils.scm
ADDED mutils/mutils.meta
Index: mutils/mutils.meta
==================================================================
--- /dev/null
+++ mutils/mutils.meta
@@ -0,0 +1,20 @@
+(
+; Your egg's license:
+(license "BSD")
+
+; 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 sparse-vectors)
+
+; A list of eggs required for TESTING ONLY. See the `Tests' section.
+(test-depends test)
+
+(author "Matt Welland")
+(synopsis "A basic description of the purpose of the egg."))
ADDED mutils/mutils.scm
Index: mutils/mutils.scm
==================================================================
--- /dev/null
+++ mutils/mutils.scm
@@ -0,0 +1,308 @@
+;; Copyright 2006-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.
+
+;; This is from the perl world, a hash of hashes is a super easy way to keep a handle on
+;; lots of disparate data
+;;
+
+(module mutils
+ *
+
+ (import chicken scheme
+ ;; data-structures posix
+ srfi-1
+ ;; srfi-13
+ srfi-69
+ ports
+ extras
+ regex
+ posix
+ data-structures
+ matchable
+ )
+
+(define (mutils:hierhash-ref hh . keys)
+ (if (null? keys)
+ #f
+ (let loop ((ht hh)
+ (key (car keys))
+ (tail (cdr keys)))
+ (if (null? tail)
+ (if (hash-table? ht)
+ (hash-table-ref/default ht key #f)
+ #f)
+ (if (hash-table? ht)
+ (loop (hash-table-ref/default ht key #f)
+ (car tail)
+ (cdr tail))
+ #f)))))
+
+;; WATCH THE NON-INTUITIVE INTERFACE HERE!!!!
+;; val comes first!
+;;
+(define (mutils:hierhash-set! hh val . keys)
+ (if (null? keys)
+ #f
+ (let loop ((ht hh)
+ (key (car keys))
+ (tail (cdr keys)))
+ (if (null? tail) ;; last one!
+ (hash-table-set! ht key val)
+ (let ((nh (hash-table-ref/default ht key #f)))
+ (if (not nh)(set! nh (make-hash-table)))
+ (hash-table-set! ht key nh)
+ (loop nh
+ (car tail)
+ (cdr tail)))))))
+
+;; nice little routine to add an item to a list in a hashtable
+;;
+(define (mutils:hash-table-add-to-list htbl key item)
+ (let ((l (hash-table-ref/default htbl key #f)))
+ (if l
+ (hash-table-set! htbl key (cons item l))
+ (hash-table-set! htbl key (list item)))))
+
+(define (mutils:hash-table-append-to-list htbl key lst)
+ (let ((l (hash-table-ref/default htbl key #f)))
+ (if l
+ (hash-table-set! htbl key (append lst l))
+ (hash-table-set! htbl key lst))))
+
+;;======================================================================
+;; Utils
+;;======================================================================
+
+(define (mutils:file->list fname)
+ (let ((fh (open-input-file fname))
+ (comment (regexp "^\\s*#"))
+ (blank (regexp "^\\s*$")))
+ (let loop ((l (read-line fh))
+ (res '()))
+ (if (eof-object? l)
+ (reverse res)
+ (if (or (string-match comment l)
+ (string-match blank l))
+ (loop (read-line fh) res)
+ (loop (read-line fh) (cons l res)))))))
+
+(use sparse-vectors)
+
+;; this is a simple two dimensional sparse array
+
+;; ONLY TWO DIMENSIONS!!! SEE ARRAY-LIB IF YOUR NEEDS ARE GREATER!!
+;;
+(define (mutils:make-sparse-array)
+ (let ((a (make-sparse-vector)))
+ (sparse-vector-set! a 0 (make-sparse-vector))
+ a))
+
+(define (mutils:sparse-array? a)
+ (and (sparse-vector? a)
+ (sparse-vector? (sparse-vector-ref a 0))))
+
+(define (mutils:sparse-array-ref a x y)
+ (let ((row (sparse-vector-ref a x)))
+ (if row
+ (sparse-vector-ref row y)
+ #f)))
+
+(define (mutils:sparse-array-set! a x y val)
+ (let ((row (sparse-vector-ref a x)))
+ (if row
+ (sparse-vector-set! row y val)
+ (let ((new-row (make-sparse-vector)))
+ (sparse-vector-set! a x new-row)
+ (sparse-vector-set! new-row y val)))))
+
+;; some routines for treating assoc lists a bit like hash tables
+
+(define (mutils:assoc-get/default alist key default)
+ (let ((res (assoc key alist)))
+ (if (and res (list? res)(> (length res) 1))
+ (cadr res)
+ default)))
+
+(define (mutils:assoc-get alist key)
+ (cadr (assoc key alist)))
+
+(define (mutils:hier-list? @hierlist)
+ (and (list? @hierlist)
+ (> (length @hierlist) 0)
+ (list? (car @hierlist))
+ (> (length (car @hierlist)) 1)))
+
+(define (mutils:hier-list-get @hierlist . @path)
+ (if (list? @hierlist)
+ (let* (($path (car @path))
+ (@rempath (cdr @path))
+ (@match (assoc $path @hierlist)))
+ (if @match
+ (if (or (not (list? @rempath))(null? @rempath))
+ (cadr @match)
+ (apply mutils:hier-list-get (cadr @match) @rempath))
+ #f))
+ #f))
+
+(define (mutils:hier-list-put! @hierlist . @path)
+ (let* (($path (car @path))
+ (@rempath (cdr @path))
+ ($value (cadr @path))
+ (@match (assoc $path @hierlist))
+ (@remhierlist (remove (lambda (a)
+ (equal? a @match))
+ @hierlist))
+ (@old-pair (let (($value (mutils:hier-list-get @hierlist $path))) (if $value $value '())))
+ (@new-pair (list $path (if (eq? (length @rempath) 1)
+ (car @rempath)
+ (apply mutils:hier-list-put! @old-pair @rempath)))))
+ (cons @new-pair @remhierlist)))
+
+(define (mutils:hier-list-remove! @hierlist . @path)
+ (let (($path (car @path)))
+ (if (eq? (length @path) 1)
+ (remove (lambda (a)
+ (equal? a (assoc $path @hierlist)))
+ @hierlist)
+ (let* ((@rempath (cdr @path))
+ (@match (assoc $path @hierlist))
+ (@remhierlist (remove (lambda (a)
+ (equal? @match a))
+ @hierlist))
+ (@old-pair (let (($value (mutils:hier-list-get @hierlist $path))) (if $value $value '())))
+ (@new-pair (list $path (apply mutils:hier-list-remove! @old-pair @rempath))))
+ (cons @new-pair @remhierlist)))))
+
+(define (mutils:keys @hierlist . @path)
+ (map (lambda (@l)
+ (if (and (list? @l)(not (null? @l)))
+ (car @l)))
+ (if (null? @path) @hierlist
+ (apply mutils:hier-list-get @hierlist @path))))
+
+;;======================================================================
+;; Other utils
+;;======================================================================
+
+(define (check-write-create fpath)
+ (and (file-write-access? fpath)
+ (let ((fname (conc fpath "/.junk-" (current-seconds) "-" (random 10000))))
+ ;;(print "trying to create/remove " fname)
+ (handle-exceptions
+ exn
+ #f
+ (begin
+ (with-output-to-file fname
+ (lambda ()
+ (print "You can delete this file")))
+ (delete-file fname)
+ #t)))))
+
+(define (run-and-return-output cmd . params)
+ (let-values (((inp oup pid)
+ (process cmd params)))
+ (let ((res (with-input-from-port inp read-lines)))
+ (let-values (((pidres status estatus)
+ (process-wait pid)))
+ (and status (eq? estatus 0) res)))))
+
+(define (confirm-ssh-access-to-host hostname)
+ (run-and-return-output "ssh" hostname "uptime"))
+
+(define (check-display dsp)
+ (run-and-return-output "xdpyinfo" "-display" dsp))
+
+#;(define (check-display dsp)
+ (let-values (((inp oup pid)
+ (process "xdpyinfo" `("-display" ,dsp))))
+ (let ((res (with-input-from-port inp read-lines)))
+ (let-values (((pidres status estatus)
+ (process-wait pid)))
+ (and status (eq? estatus 0) res)))))
+
+;; do some sanity checks on the system
+;;
+(define (mutils:syscheck common:raw-get-remote-host-load
+ server:get-best-guess-address
+ read-config)
+ ;; current dir writeable and do megatest.config, runconfigs.config files exist/readable
+ (print "Current directory " (current-directory) " writeable: "
+ (if (check-write-create ".") "yes" "NO"))
+ ;; home dir writeable
+ (print "Home directory " (get-environment-variable "HOME") " writeable: "
+ (if (check-write-create (get-environment-variable "HOME")) "yes" "NO"))
+ ;; /tmp writeable
+ (print "/tmp directory writeable: " (if (check-write-create "/tmp") "yes" "NO"))
+ ;; load configs
+ (print "$DISPLAY set: " (if (get-environment-variable "DISPLAY")
+ (conc (get-environment-variable "DISPLAY") " yes")
+ "NO"))
+
+ (print "$DISPLAY accessible? "
+ ;; (eq? (system "xdpyinfo -display $DISPLAY &>/dev/null") 0)
+ (if (check-display (get-environment-variable "DISPLAY"))
+ "yes" "NO"))
+
+ (print "Password-less ssh access to localhost: "
+ (if (confirm-ssh-access-to-host "localhost")
+ "yes"
+ "NO"))
+
+ ;; if I'm in a Megatest area do some checks
+ (print "Have megatest.config: "
+ (if (file-exists? "megatest.config")
+ "yes"
+ "NO"))
+
+ (print "Have runconfigs.config: "
+ (if (file-exists? "runconfigs.config")
+ "yes"
+ "NO"))
+
+ (if (file-exists? ".homehost")
+ (let* ((homehost (with-input-from-file ".homehost"
+ read-line))
+ (currhost (get-host-name))
+ (bestadrs (server:get-best-guess-address currhost)))
+ (print "Have .homehost and it is the localhost: "
+ (if (equal? homehost bestadrs)
+ "yes"
+ (conc ".homehost=" homehost ", localhost=" bestadrs ", NO")))
+ (print "Have .homehost and it is reachable via ssh: "
+ (if (confirm-ssh-access-to-host homehost)
+ "yes"
+ "NO"))
+ ))
+
+ (if (file-exists? "megatest.config")
+ (let* ((cdat (read-config "megatest.config" #f #f)))
+ (print "Have [disks] section: "
+ (if (hash-table-ref/default cdat "disks" #f)
+ (conc (hash-table-ref cdat "disks") " yes")
+ "NO"))
+ (for-each
+ (lambda (entry)
+ (match
+ entry
+ ((dname path)
+ (print "Disk " dname " at " path " writeable: "
+ (if (check-write-create path) "yes" "NO")))
+ (else (print "bad entry: " entry))))
+ (hash-table-ref/default cdat "disks" '()))))
+
+ (print "Have link tree and it is writable: "
+ (if (and (file-exists? "lt")
+ (check-write-create "lt"))
+ "yes"
+ "NO"))
+ ;; check load on homehost
+ ;; link tree writeable
+ )
+
+)
ADDED mutils/mutils.setup
Index: mutils/mutils.setup
==================================================================
--- /dev/null
+++ mutils/mutils.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.
+
+;;;; mutils.setup
+
+;; compile the code into a dynamically loadable shared object
+;; (will generate mutils.so)
+(compile -s mutils.scm)
+
+;; Install as extension library
+(install-extension 'mutils "mutils.so")
+
ADDED mutils/tests/datastruct.scm
Index: mutils/tests/datastruct.scm
==================================================================
--- /dev/null
+++ mutils/tests/datastruct.scm
@@ -0,0 +1,15 @@
+
+(use test)
+
+(include "datastruct.scm")
+
+(define hh (make-hash-table))
+
+(hierhash-set! hh 5 1 2 3 4)
+
+(test 5 (hierhash-ref hh 1 2 3 4))
+
+(hierhash-set! hh 10 1 2 3 5)
+
+(test 10 (hierhash-ref hh 1 2 3 5))
+(test 5 (hierhash-ref hh 1 2 3 4))
ADDED pkts.scm
Index: pkts.scm
==================================================================
--- /dev/null
+++ pkts.scm
@@ -0,0 +1,23 @@
+;;======================================================================
+;; Copyright 2019, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+;;======================================================================
+
+(declare (unit pkts))
+
+(include "pkts/pkts.scm")
ADDED pkts/pktrec.scm
Index: pkts/pktrec.scm
==================================================================
--- /dev/null
+++ pkts/pktrec.scm
@@ -0,0 +1,196 @@
+(define-syntax define-record-type
+ (syntax-rules ()
+ ((define-record-type type
+ (constructor constructor-tag ...)
+ predicate
+ (field-tag accessor . more) ...)
+ (begin
+ (define type
+ (make-record-type 'type '(field-tag ...)))
+ (define constructor
+ (record-constructor type '(constructor-tag ...)))
+ (define predicate
+ (record-predicate type))
+ (define-record-field type field-tag accessor . more)
+ ...))))
+
+; An auxilliary macro for define field accessors and modifiers.
+; This is needed only because modifiers are optional.
+
+(define-syntax define-record-field
+ (syntax-rules ()
+ ((define-record-field type field-tag accessor)
+ (define accessor (record-accessor type 'field-tag)))
+ ((define-record-field type field-tag accessor modifier)
+ (begin
+ (define accessor (record-accessor type 'field-tag))
+ (define modifier (record-modifier type 'field-tag))))))
+
+; Record types
+
+; We define the following procedures:
+;
+; (make-record-type ) ->
+; (record-constructor ) ->
+; (record-predicate ) ->
+; (record-accessor ) ->
+; (record-modifier ) ->
+; where
+; ( ...) ->
+; () ->
+; () ->
+; () ->
+
+; Record types are implemented using vector-like records. The first
+; slot of each record contains the record's type, which is itself a
+; record.
+
+(define (record-type record)
+ (record-ref record 0))
+
+;----------------
+; Record types are themselves records, so we first define the type for
+; them. Except for problems with circularities, this could be defined as:
+; (define-record-type :record-type
+; (make-record-type name field-tags)
+; record-type?
+; (name record-type-name)
+; (field-tags record-type-field-tags))
+; As it is, we need to define everything by hand.
+
+(define :record-type (make-record 3))
+(record-set! :record-type 0 :record-type) ; Its type is itself.
+(record-set! :record-type 1 ':record-type)
+(record-set! :record-type 2 '(name field-tags))
+
+; Now that :record-type exists we can define a procedure for making more
+; record types.
+
+(define (make-record-type name field-tags)
+ (let ((new (make-record 3)))
+ (record-set! new 0 :record-type)
+ (record-set! new 1 name)
+ (record-set! new 2 field-tags)
+ new))
+
+; Accessors for record types.
+
+(define (record-type-name record-type)
+ (record-ref record-type 1))
+
+(define (record-type-field-tags record-type)
+ (record-ref record-type 2))
+
+;----------------
+; A utility for getting the offset of a field within a record.
+
+(define (field-index type tag)
+ (let loop ((i 1) (tags (record-type-field-tags type)))
+ (cond ((null? tags)
+ (error "record type has no such field" type tag))
+ ((eq? tag (car tags))
+ i)
+ (else
+ (loop (+ i 1) (cdr tags))))))
+
+;----------------
+; Now we are ready to define RECORD-CONSTRUCTOR and the rest of the
+; procedures used by the macro expansion of DEFINE-RECORD-TYPE.
+
+(define (record-constructor type tags)
+ (let ((size (length (record-type-field-tags type)))
+ (arg-count (length tags))
+ (indexes (map (lambda (tag)
+ (field-index type tag))
+ tags)))
+ (lambda args
+ (if (= (length args)
+ arg-count)
+ (let ((new (make-record (+ size 1))))
+ (record-set! new 0 type)
+ (for-each (lambda (arg i)
+ (record-set! new i arg))
+ args
+ indexes)
+ new)
+ (error "wrong number of arguments to constructor" type args)))))
+
+(define (record-predicate type)
+ (lambda (thing)
+ (and (record? thing)
+ (eq? (record-type thing)
+ type))))
+
+(define (record-accessor type tag)
+ (let ((index (field-index type tag)))
+ (lambda (thing)
+ (if (and (record? thing)
+ (eq? (record-type thing)
+ type))
+ (record-ref thing index)
+ (error "accessor applied to bad value" type tag thing)))))
+
+(define (record-modifier type tag)
+ (let ((index (field-index type tag)))
+ (lambda (thing value)
+ (if (and (record? thing)
+ (eq? (record-type thing)
+ type))
+ (record-set! thing index value)
+ (error "modifier applied to bad value" type tag thing)))))
+
+Records
+
+; This implements a record abstraction that is identical to vectors,
+; except that they are not vectors (VECTOR? returns false when given a
+; record and RECORD? returns false when given a vector). The following
+; procedures are provided:
+; (record? ) ->
+; (make-record ) ->
+; (record-ref ) ->
+; (record-set! ) ->
+;
+; These can implemented in R5RS Scheme as vectors with a distinguishing
+; value at index zero, providing VECTOR? is redefined to be a procedure
+; that returns false if its argument contains the distinguishing record
+; value. EVAL is also redefined to use the new value of VECTOR?.
+
+; Define the marker and redefine VECTOR? and EVAL.
+
+(define record-marker (list 'record-marker))
+
+(define real-vector? vector?)
+
+(define (vector? x)
+ (and (real-vector? x)
+ (or (= 0 (vector-length x))
+ (not (eq? (vector-ref x 0)
+ record-marker)))))
+
+; This won't work if ENV is the interaction environment and someone has
+; redefined LAMBDA there.
+
+(define eval
+ (let ((real-eval eval))
+ (lambda (exp env)
+ ((real-eval `(lambda (vector?) ,exp))
+ vector?))))
+
+; Definitions of the record procedures.
+
+(define (record? x)
+ (and (real-vector? x)
+ (< 0 (vector-length x))
+ (eq? (vector-ref x 0)
+ record-marker)))
+
+(define (make-record size)
+ (let ((new (make-vector (+ size 1))))
+ (vector-set! new 0 record-marker)
+ new))
+
+(define (record-ref record index)
+ (vector-ref record (+ index 1)))
+
+(define (record-set! record index value)
+ (vector-set! record (+ index 1) value))
ADDED pkts/pkts.meta
Index: pkts/pkts.meta
==================================================================
--- /dev/null
+++ pkts/pkts.meta
@@ -0,0 +1,21 @@
+;; -*- scheme -*-
+(
+; Your egg's license:
+(license "BSD")
+
+; Pick one from the list of categories (see below) for your egg and enter it
+; here.
+(category db)
+
+; A list of eggs pkts 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 (autoload "3.0"))
+
+; A list of eggs required for TESTING ONLY. See the `Tests' section.
+(test-depends test)
+
+(author "Matt Welland")
+(synopsis "A sha1-chain based datastore built on packets consisting of single line cards modeled loosely on the fossil scm datastore."))
ADDED pkts/pkts.release-info
Index: pkts/pkts.release-info
==================================================================
--- /dev/null
+++ pkts/pkts.release-info
@@ -0,0 +1,3 @@
+(repo fossil "http://www.kiatoa.com/cgi-bin/fossils/{egg-name}")
+(uri zip "http://www.kiatoa.com/cgi-bin/fossils/{egg-name}/zip/{egg-name}.zip?uuid={egg-release}")
+(release "1.0")
ADDED pkts/pkts.scm
Index: pkts/pkts.scm
==================================================================
--- /dev/null
+++ pkts/pkts.scm
@@ -0,0 +1,1075 @@
+;; Copyright 2006-2017, Matthew Welland.
+;;
+;; This file is part of Pkts
+;;
+;; Pkts is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Pkts is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Pkts. If not, see .
+;;
+
+;; CARDS:
+;;
+;; A card is a line of text, the first two characters are a letter followed by a
+;; space. The letter is the card type.
+;;
+;; PKTS:
+;;
+;; A pkt is a sorted list of cards with a final card Z that contains the shar1 hash
+;; of all of the preceding cards.
+;;
+;; APKT:
+;;
+;; An alist mapping card types to card data
+;; '((T . "pkttype")
+;; (a . "some content"))
+;;
+;; EPKT:
+;;
+;; Extended packet using friendly keys. Must use a pktspec to convert to/from epkts
+;; '((ptype . "pkttype")
+;; (adata . "some content))
+;;
+;; DPKT:
+;;
+;; pkts pulled from the database have this format:
+;;
+;;((apkt (Z . "7de89c09ac024b3832c93e16cd78d11e2e28733b") <= this is a the alist
+;; (t . "v1.63/tip/dev")
+;; (c . "QUICKPATT")
+;; (T . "runstart")
+;; (P . "354eeb67120a921e3e33155ecab1b522ac10b6bd")
+;; (D . "1488995096.0"))
+;; (id . 8)
+;; (group-id . 0)
+;; (uuid . "7de89c09ac024b3832c93e16cd78d11e2e28733b")
+;; (parent . "")
+;; (pkt-type . "runstart")
+;; (pkt . "D 1488995096.0\nP 354eeb67120a921e3e33155ecab1b522ac10b6bd\nT runstart\nc QUICKPATT\nt v1.63/tip/dev\nZ 7de89c09ac024b3832c93e16cd78d11e2e28733b"))
+;;
+;; pktspec is alist of alists mapping types and nicekeys to keys
+;;
+;; '((posting . ((title . t)
+;; (url . u)
+;; (blurb . b)))
+;; (comment . ((comment . c)
+;; (score . s))))
+
+;; Reserved cards:
+;; P : pkt parent
+;; R : reference pkt containing mapping of short string -> sha1sum strings
+;; T : pkt type
+;; D : current time from (current-time), unless provided
+;; Z : shar1 hash of the packet
+
+;; Example usage:
+;;
+;; Create a pkt:
+;;
+;; (use pkts)
+;; (define-values (uuid pkt)
+;; (alist->pkt
+;; '((fruit . "apple") (meat . "beef")) ;; this is the data to convert
+;; '((foods (fruit . f) (meat . m))) ;; this is the pkt spec
+;; ptype:
+;; 'foods))
+;;
+;; Add to pkt queue:
+;;
+;; (define db (open-queue-db "/tmp/pkts" "pkts.db"))
+;; (add-to-queue db pkt uuid 'foods #f 0) ;; no parent and use group_id of 0
+;;
+;; Retrieve the packet from the db and extract a value:
+;;
+;; (alist-ref
+;; 'meat
+;; (dpkt->alist
+;; (car (get-dpkts db #f 0 #f))
+;; '((foods (fruit . f)
+;; (meat . m)))))
+;; => "beef"
+;;
+
+(module pkts
+(
+;; cards, util and misc
+;; sort-cards
+;; calc-shar1
+;;
+;; low-level constructor procs, exposed only for development/testing, will be removed
+construct-sdat
+construct-pkt
+card->type/value
+add-z-card
+
+;; queue database procs
+open-queue-db
+add-to-queue
+create-and-queue
+lookup-by-uuid
+lookup-by-id
+get-dpkts
+get-not-processed-pkts
+get-related
+find-pkts
+process-pkts
+get-descendents
+get-ancestors
+get-pkts
+get-last-descendent
+with-queue-db
+load-pkts-to-db
+
+;; procs that operate directly on pkts, sdat, apkts, dpkts etc.
+pkt->alist ;; pkt -> apkt (i.e. alist)
+pkt->sdat ;; pkt -> '("a aval" "b bval" ...)
+sdat->alist ;; '("a aval" "b bval"...) -> ((a . "aval")(b . "bval") ...)
+dblst->dpkts ;; convert list of tuples from queue db into dpkts
+dpkt->alist ;; flatten a dpkt into an alist containing all db fields and the pkt alist
+dpkts->alists ;; apply dpkt->alist to a list of alists using a pkt-spec
+alist->pkt ;; returns two values uuid, pkt
+get-value ;; looks up a value given a key in a dpkt
+flatten-all ;; merge the list of values from a query which includes a pkt into a flat alist <== really useful!
+check-pkt
+
+;; pkt alists
+write-alist->pkt
+read-pkt->alist
+
+;; archive database
+archive-open-db
+write-archive-pkts
+archive-pkts
+mark-processed
+
+;; pktsdb
+pktdb-conn ;; useful
+pktdb-fname
+pktsdb-open
+pktsdb-close
+pktsdb-add-record
+;; temporary
+pktdb-pktspec
+
+;; utility procs
+increment-string ;; used to get indexes for strings in ref pkts
+make-report ;; make a .dot file
+)
+
+(import chicken scheme data-structures posix srfi-1 regex srfi-13 srfi-69 ports extras)
+(use crypt sha1 message-digest (prefix dbi dbi:) typed-records)
+
+;;======================================================================
+;; DATA MANIPULATION UTILS
+;;======================================================================
+
+(define-inline (unescape-data data)
+ (string-translate* data '(("\\n" . "\n") ("\\\\" . "\\"))))
+
+(define-inline (escape-data data)
+ (string-translate* data '(("\n" . "\\n") ("\\" . "\\\\"))))
+
+(define-inline (make-card type data)
+ (conc type " " (escape-data (->string data))))
+
+;; reverse an alist for doing pktkey -> external key conversions
+;;
+(define-inline (reverse-aspec aspec)
+ (map (lambda (dat)
+ (cons (cdr dat)(car dat)))
+ aspec))
+
+;; add a card to the list of cards, sdat
+;; if type is #f return only sdat
+;; if data is #f return only sdat
+;;
+(define-inline (add-card sdat type data)
+ (if (and type data)
+ (cons (make-card type data) sdat)
+ sdat))
+
+;;======================================================================
+;; STRING AS FUNKY NUMBER
+;;======================================================================
+
+;; NOTE: PTDZ are removed as they are reserved. NB// the R card is not used in a
+;; ref, instead the P parent card is used.
+;; Question: Why does it matter to remove PTDZ?
+;; To make the ref easier to use the ref strings will be the keys
+;; so we cannot have overlap with any actual keys. But this is a
+;; bit silly. What we need to do instead is reject keys of length
+;; one where the char is in PTDZ
+;;
+;; This is basically base92
+;;
+(define string-num-chars (string->list "!#$%&'()*+,-./0123456789:;<=>?@ABCEFGHIJKLMNOQRSUVWXY[\\]^_abcdefghijklmnopqrstuvwxyz{|}~"))
+;; "0123456789abcdefghijklmnopqrstuvwxyzABCEFGHIJKLMNOQSUVWXY!#$%&'()*+,-./[]:;<=>?\\^_{}|"))
+
+(define (char-incr inchar)
+ (let* ((carry #f)
+ (next-char (let ((rem (member inchar string-num-chars)))
+ (if (eq? (length rem) 1) ;; we are at the last character in our string-num-chars list
+ (begin
+ (set! carry #t)
+ (car string-num-chars))
+ (cadr rem)))))
+ (values next-char carry)))
+
+(define (increment-string str)
+ (if (string-null? str)
+ "0"
+ (let ((strlst (reverse (string->list str)))) ;; need to process the string from the lsd
+ (list->string
+ (let loop ((hed (car strlst))
+ (tal (cdr strlst))
+ (res '()))
+ (let-values (((newhed carry)(char-incr hed)))
+ ;; (print "newhed: " newhed " carry: " carry " tal: " tal)
+ (let ((newres (cons newhed res)))
+ (if carry ;; we'll have to propagate the carry
+ (if (null? tal) ;; at the end, tack on "0" (which is really a "1")
+ (cons (car string-num-chars) newres)
+ (loop (car tal)(cdr tal) newres))
+ (append (reverse tal) newres)))))))))
+
+;;======================================================================
+;; P K T S D B I N T E R F A C E
+;;
+;; INTEGER, REAL, TEXT
+;;======================================================================
+;;
+;; spec
+;; ( (tablename1 . (field1name L1 TYPE)
+;; (field2name L2 TYPE) ... )
+;; (tablename2 ... ))
+;;
+;; Example: (tests (testname n TEXT)
+;; (rundir r TEXT)
+;; ... )
+;;
+;; pkt keys are taken from the first letter, if that is not unique
+;; then look at the next letter and so on
+;;
+
+;; use this struct to hold the pktspec and the db handle
+;;
+(defstruct pktdb
+ (fname #f)
+ (pktsdb-spec #f)
+ (pktspec #f) ;; cache the pktspec
+ (field-keys #f) ;; cache the field->key mapping (field1 . k1) ...
+ (key-fields #f) ;; cache the key->field mapping
+ (conn #f)
+ )
+
+;; WARNING: There is a simplification in the pktsdb spec w.r.t. pktspec.
+;; The field specs are the cdr of the table list - not a full
+;; list. The extra list level in pktspec is gratuitous and should
+;; be removed.
+;;
+(define (pktsdb-spec->pktspec tables-spec)
+ (map (lambda (tablespec)
+ (list (car tablespec)
+ (map (lambda (field-spec)
+ (cons (car field-spec)(cadr field-spec)))
+ (cdr tablespec))))
+ tables-spec))
+
+(define (pktsdb-open dbfname pktsdb-spec)
+ (let* ((pdb (make-pktdb))
+ (dbexists (file-exists? dbfname))
+ (db (dbi:open 'sqlite3 `((dbname . ,dbfname)))))
+ (pktdb-pktsdb-spec-set! pdb pktsdb-spec)
+ (pktdb-pktspec-set! pdb (pktsdb-spec->pktspec pktsdb-spec))
+ (pktdb-fname-set! pdb dbfname)
+ (pktdb-conn-set! pdb db)
+ (if (not dbexists)
+ (pktsdb-init pdb))
+ pdb))
+
+(define (pktsdb-init pktsdb)
+ (let* ((db (pktdb-conn pktsdb))
+ (pktsdb-spec (pktdb-pktsdb-spec pktsdb)))
+ ;; create a table for the pkts themselves
+ (dbi:exec db "CREATE TABLE IF NOT EXISTS pkts (id INTEGER PRIMARY KEY, zkey TEXT, record_id INTEGER, pkt TEXT);")
+ (for-each
+ (lambda (table)
+ (let* ((table-name (car table))
+ (fields (cdr table))
+ (stmt (conc "CREATE TABLE IF NOT EXISTS "
+ table-name
+ " (id INTEGER PRIMARY KEY,"
+ (string-intersperse
+ (map (lambda (fieldspec)
+ (conc (car fieldspec) " "
+ (caddr fieldspec)))
+ fields)
+ ",")
+ ");")))
+ (dbi:exec db stmt)))
+ pktsdb-spec)))
+
+;; create pkt from the data and insert into pkts table
+;;
+;; data is assoc list of (field . value) ...
+;; tablename is a symbol matching the table name
+;;
+(define (pktsdb-add-record pktsdb tablename data #!optional (parent #f))
+ (let*-values (((zkey pkt) (alist->pkt data (pktdb-pktspec pktsdb) ptype: tablename)))
+ ;; have the data as alist so insert it into appropriate table also
+ (let* ((db (pktdb-conn pktsdb)))
+ ;; TODO: Address collisions
+ (dbi:exec db "INSERT INTO pkts (zkey,pkt,record_id) VALUES (?,?,?);"
+ zkey pkt -1)
+ (let* (;; (pktid (pktsdb-pktkey->pktid pktsdb pktkey))
+ (record-id (pktsdb-insert pktsdb tablename data)))
+ (dbi:exec db "UPDATE pkts SET record_id=? WHERE zkey=?;"
+ record-id zkey)
+ ))))
+
+;;
+(define (pktsdb-insert pktsdb tablename data)
+ (let* ((db (pktdb-conn pktsdb))
+ (stmt (conc "INSERT INTO " tablename
+ " (" (string-intersperse (map conc (map car data)) ",")
+ ") VALUES ('"
+ ;; TODO: Add lookup of data type and do not
+ ;; wrap integers with quotes
+ (string-intersperse (map conc (map cdr data)) "','")
+ "');")))
+ (print "stmt: " stmt)
+ (dbi:exec db stmt)
+ ;; lookup the record-id and return it
+
+ ))
+
+
+(define (pktsdb-close pktsdb)
+ (dbi:close (pktdb-conn pktsdb)))
+
+;; (let loop ((s "0")(n 0))(print s)(if (< n 5000)(loop (increment-string s)(+ n 1))))
+
+;;======================================================================
+;; CARDS, MISC and UTIL
+;;======================================================================
+
+;; given string (likely multi-line) "dat" return shar1 hash
+;;
+(define-inline (calc-shar1 instr)
+ (message-digest-string
+ (sha1-primitive)
+ instr))
+
+;; given a single card return its type and value
+;;
+(define (card->type/value card)
+ (let ((ctype (substring card 0 1))
+ (cval (substring card 2 (string-length card))))
+ (values (string->symbol ctype) cval)))
+
+;;======================================================================
+;; SDAT procs
+;; sdat is legacy/internal usage. Intention is to remove sdat calls from
+;; the exposed calls.
+;;======================================================================
+
+;; sort list of cards
+;;
+(define-inline (sort-cards sdat)
+ (sort sdat string<=?))
+
+;; pkt rules
+;; 1. one card per line
+;; 2. at least one card
+;; 3. no blank lines
+
+;; given sdat, a list of cards return uuid, packet (as sdat)
+;;
+(define (add-z-card sdat)
+ (let* ((sorted-sdat (sort-cards sdat))
+ (dat (string-intersperse sorted-sdat "\n"))
+ (uuid (calc-shar1 dat)))
+ (values
+ uuid
+ (conc
+ dat
+ "\nZ "
+ uuid))))
+
+(define (check-pkt pkt)
+ (handle-exceptions
+ exn
+ #f ;; anything goes wrong - call it a crappy pkt
+ (let* ((sdat (string-split pkt "\n"))
+ (rdat (reverse sdat)) ;; reversed
+ (zdat (car rdat))
+ (Z (cadr (string-split zdat)))
+ (cdat (string-intersperse (reverse (cdr rdat)) "\n")))
+ (equal? Z (calc-shar1 cdat)))))
+
+;;======================================================================
+;; APKTs
+;;======================================================================
+
+;; convert a sdat (list of cards) to an alist
+;;
+(define (sdat->alist sdat)
+ (let loop ((hed (car sdat))
+ (tal (cdr sdat))
+ (res '()))
+ (let-values (( (ctype cval)(card->type/value hed) ))
+ ;; if this card is not one of the common ones tack it on to rem
+ (let* ((oldval (alist-ref ctype res))
+ (newres (cons (cons ctype
+ (if oldval ;; list or string
+ (if (list? oldval)
+ (cons cval oldval)
+ (cons cval (list oldval)))
+ cval))
+ res)))
+ (if (null? tal)
+ newres
+ (loop (car tal)(cdr tal) newres))))))
+
+;;((apkt (Z . "7de89c09ac024b3832c93e16cd78d11e2e28733b") <= this is a the alist
+;; (t . "v1.63/tip/dev")
+;; (c . "QUICKPATT")
+;; (T . "runstart")
+;; (P . "354eeb67120a921e3e33155ecab1b522ac10b6bd")
+;; (D . "1488995096.0"))
+;; (id . 8)
+;; (group-id . 0)
+;; (uuid . "7de89c09ac024b3832c93e16cd78d11e2e28733b")
+;; (parent . "")
+;; (pkt-type . "runstart")
+;; (pkt . "D 1488995096.0\nP 354eeb67120a921e3e33155ecab1b522ac10b6bd\nT runstart\nc QUICKPATT\nt v1.63/tip/dev\nZ 7de89c09ac024b3832c93e16cd78d11e2e28733b"))
+;;
+;; pktspec is alist of alists mapping types and nicekeys to keys
+;;
+;; '((posting . ((title . t)
+;; (url . u)
+;; (blurb . b)))
+;; (comment . ((comment . c)
+;; (score . s))))
+
+;; DON'T USE?
+;;
+(define (get-value field dpkt . spec-in)
+ (if (null? spec-in)
+ (alist-ref field dpkt)
+ (let* ((spec (car spec-in))
+ (apkt (alist-ref 'apkt dpkt))) ;; get the pkt alist
+ (if (and apkt spec)
+ (let* ((ptype (alist-ref 'pkt-type dpkt))
+ (pspec (alist-ref (string->symbol ptype) spec))) ;; do we have a spec for this type of pkt
+ (and pspec
+ (let* ((key (alist-ref field pspec)))
+ (and key (alist-ref key apkt)))))
+ #f))))
+
+;; convert a dpkt to a pure alist given a pktspec
+;; this flattens out the alist to include the data from
+;; the queue database record
+;;
+(define (dpkt->alist dpkt pktspec)
+ (let* ((apkt (alist-ref 'apkt dpkt))
+ (pkt-type (or (alist-ref 'pkt-type dpkt) ;; pkt-type is from the database field pkt_type
+ (alist-ref 'T apkt)))
+ (pkt-fields (alist-ref (string->symbol pkt-type) pktspec))
+ (rev-fields (if pkt-fields
+ (reverse-aspec pkt-fields)
+ '())))
+ (append (map (lambda (entry)
+ (let* ((pkt-key (car entry))
+ (new-key (or (alist-ref pkt-key rev-fields) pkt-key)))
+ `(,new-key . ,(cdr entry))))
+ apkt)
+ dpkt)))
+
+;; convert a list of dpkts into a list of alists using pkt-spec
+;;
+(define (dpkts->alists dpkts pkt-spec)
+ (map (lambda (x)
+ (dpkt->alist x pkt-spec))
+ dpkts))
+
+;; Generic flattener, make the tuple and pkt into a single flat alist
+;;
+;; qry-result-spec is a list of symbols corresponding to each field
+;;
+(define (flatten-all inlst pktspec . qry-result-spec)
+ (map
+ (lambda (tuple)
+ (dpkt->alist
+ (apply dblst->dpkts tuple qry-result-spec)
+ pktspec))
+ inlst))
+
+;; call like this:
+;; (construct-sdat 'a "a data" 'S "S data" ...)
+;; returns list of cards
+;; ( "A a value" "D 12345678900" ...)
+;;
+(define (construct-sdat . alldat)
+ (let ((have-D-card #f)) ;; flag
+ (if (even? (length alldat))
+ (let loop ((type (car alldat))
+ (data (cadr alldat))
+ (tail (cddr alldat))
+ (res '()))
+ (if (eq? type 'D)(set! have-D-card #t))
+ (if (null? tail)
+ (if have-D-card ;; return the constructed pkt, add a D card if none found
+ (add-card res type data)
+ (add-card
+ (add-card res 'D (current-seconds))
+ type data))
+ (loop (car tail)
+ (cadr tail)
+ (cddr tail)
+ (add-card res type data))))
+ #f))) ;; #f means it failed to create the sdat
+
+(define (construct-pkt . alldat)
+ (add-z-card
+ (apply construct-sdat alldat)))
+
+;;======================================================================
+;; CONVERTERS
+;;======================================================================
+
+(define (pkt->sdat pkt)
+ (map unescape-data (string-split pkt "\n")))
+
+;; given a pure pkt return an alist
+;;
+(define (pkt->alist pkt #!key (pktspec #f))
+ (let ((sdat (cond
+ ((string? pkt) (pkt->sdat pkt))
+ ((list? pkt) pkt)
+ (else #f))))
+ (if pkt
+ (if pktspec
+ (dpkt->alist (list (cons 'apkt (sdat->alist sdat))) pktspec)
+ (sdat->alist sdat))
+ #f)))
+
+;; convert an alist to an sdat
+;; in: '((a . "blah")(b . "foo"))
+;; out: '("a blah" "b foo")
+;;
+(define (alist->sdat adat)
+ (map (lambda (dat)
+ (conc (car dat) " " (cdr dat)))
+ adat))
+
+;; adat is the incoming alist, aspec is the mapping
+;; from incoming key to the pkt key (usually one
+;; letter to keep data tight) see the pktspec at the
+;; top of this file
+;;
+;; NOTE: alists can contain multiple instances of the same key (supported fine by pkts)
+;; but you (obviously I suppose) cannot use alist-ref to access those entries.
+;;
+(define (alist->pkt adat aspec #!key (ptype #f))
+ (let* ((pkt-type (or ptype
+ (alist-ref 'T adat) ;; can provide in the incoming alist
+ #f))
+ (pkt-spec (if pkt-type ;; alist of external-key -> key
+ (or (alist-ref pkt-type aspec) '())
+ (if (null? aspec)
+ '()
+ (cdar aspec)))) ;; default to first one if nothing specified
+ (new-alist (map (lambda (dat)
+ (let* ((key (car dat))
+ (val (cdr dat))
+ (newkey (or (alist-ref key pkt-spec)
+ key)))
+ (cons newkey (escape-data (conc val))))) ;; convert all incoming data (symbols, numbers etc.) to a string and then escape newlines.
+ adat))
+ (new-with-type (if (alist-ref 'T new-alist)
+ new-alist
+ (cons `(T . ,pkt-type) new-alist)))
+ (with-d-card (if (alist-ref 'D new-with-type)
+ new-with-type
+ (cons `(D . ,(current-seconds))
+ new-with-type))))
+ (add-z-card
+ (alist->sdat with-d-card))))
+
+;;======================================================================
+;; D B Q U E U E I N T E R F A C E
+;;======================================================================
+
+;; pkts (
+;; id SERIAL PRIMARY KEY,
+;; uuid TEXT NOT NULL,
+;; parent_uuid TEXT default '',
+;; pkt_type INTEGER DEFAULT 0,
+;; group_id INTEGER NOT NULL,
+;; pkt TEXT NOT NULL
+
+;; schema is list of SQL statements - can be used to extend db with more tables
+;;
+(define (open-queue-db dbpath dbfile #!key (schema '()))
+ (let* ((dbfname (conc dbpath "/" dbfile))
+ (dbexists (if (file-exists? dbfname) #t (begin (create-directory dbpath #t) #f)))
+ (db (dbi:open 'sqlite3 (list (cons 'dbname dbfname)))))
+ ;; (set-busy-handler! db (busy-timeout 10000))
+ (if (not dbexists) ;; NOTE: In the archive we allow duplicates and other messiness.
+ (for-each
+ (lambda (stmt)
+ (dbi:exec db stmt))
+ (cons "CREATE TABLE IF NOT EXISTS pkts
+ (id INTEGER PRIMARY KEY,
+ group_id INTEGER NOT NULL,
+ uuid TEXT NOT NULL,
+ parent_uuid TEXT TEXT DEFAULT '',
+ pkt_type TEXT NOT NULL,
+ pkt TEXT NOT NULL,
+ processed INTEGER DEFAULT 0)"
+ schema))) ;; 0=not processed, 1=processed, 2... for expansion
+ db))
+
+(define (add-to-queue db pkt uuid pkt-type parent-uuid group-id)
+ (dbi:exec db "INSERT INTO pkts (uuid,parent_uuid,pkt_type,pkt,group_id)
+ VALUES(?,?,?,?,?);" ;; $1,$2,$3,$4,$5);"
+ uuid
+ (if parent-uuid parent-uuid "");; use null string as placeholder for no parent uuid.
+ (if pkt-type (conc pkt-type) "")
+ pkt
+ group-id))
+
+;; given all needed parameters create a pkt and store it in the queue
+;; procs is an alist that maps pkt-type to a function that takes a list of pkt params
+;; in data and returns the uuid and pkt
+;;
+(define (create-and-queue conn procs pkt-type parent-uuid group-id data)
+ (let ((proc (alist-ref pkt-type procs)))
+ (if proc
+ (let-values (( (uuid pkt) (proc data) ))
+ (add-to-queue conn pkt uuid pkt-type parent-uuid group-id)
+ uuid)
+ #f)))
+
+;; given uuid get pkt, if group-id is specified use it (reduces probablity of
+;; being messed up by a uuid collision)
+;;
+(define (lookup-by-uuid db pkt-uuid group-id)
+ (if group-id
+ (dbi:get-one db "SELECT pkt FROM pkts WHERE group_id=? AND uuid=?;" group-id pkt-uuid)
+ (dbi:get-one db "SELECT pkt FROM pkts WHERE uuid=?;" pkt-uuid)))
+
+;; find a packet by its id
+;;
+(define (lookup-by-id db id)
+ (dbi:get-one db "SELECT pkt FROM pkts WHERE id=?;" id))
+
+;; apply a proc to the open db handle for a pkt db in pdbpath
+;;
+(define (with-queue-db pdbpath proc #!key (schema #f))
+ (cond
+ ((not (equal? (file-owner pdbpath)(current-effective-user-id)))
+ (print "ERROR: directory " pdbpath " is not owned by " (current-effective-user-name)))
+ (else
+ (let* ((pdb (open-queue-db pdbpath "pkts.db"
+ schema: schema)) ;; '("CREATE TABLE groups (id INTEGER PRIMARY KEY,groupname TEXT, CONSTRAINT group_constraint UNIQUE (groupname));"))))
+ (res (proc pdb)))
+ (dbi:close pdb)
+ res))))
+
+(define (load-pkts-to-db pktsdirs pdbpath #!key (schema #f))
+ (with-queue-db
+ pdbpath
+ (lambda (pdb)
+ (for-each
+ (lambda (pktsdir) ;; look at all
+ (cond
+ ((not (file-exists? pktsdir))
+ (print "ERROR: packets directory " pktsdir " does not exist."))
+ ((not (directory? pktsdir))
+ (print "ERROR: packets directory path " pktsdir " is not a directory."))
+ ((not (file-read-access? pktsdir))
+ (print "ERROR: packets directory path " pktsdir " is not readable."))
+ (else
+ ;; (print "INFO: Loading packets found in " pktsdir)
+ (let ((pkts (glob (conc pktsdir "/*.pkt"))))
+ (for-each
+ (lambda (pkt)
+ (let* ((uuid (cadr (string-match ".*/([0-9a-f]+).pkt" pkt)))
+ (exists (lookup-by-uuid pdb uuid #f)))
+ (if (not exists)
+ (let* ((pktdat (string-intersperse
+ (with-input-from-file pkt read-lines)
+ "\n"))
+ (apkt (pkt->alist pktdat))
+ (ptype (alist-ref 'T apkt)))
+ (add-to-queue pdb pktdat uuid (or ptype 'cmd) #f 0))
+ ;; (debug:print 4 *default-log-port* "Added " uuid " of type " ptype " to queue"))
+ ;; (debug:print 4 *default-log-port* "pkt: " uuid " exists, skipping...")
+ )))
+ pkts)))))
+ pktsdirs))))
+
+;;======================================================================
+;; P R O C E S S P K T S
+;;======================================================================
+
+;; given a list of field values pulled from the queue db generate a list
+;; of dpkt's
+;;
+(define (dblst->dpkts lst . altmap)
+ (let* ((maplst (if (null? altmap)
+ '(id group-id uuid parent pkt-type pkt processed)
+ altmap))
+ (res (map cons maplst lst))) ;; produces list of pairs, i.e an alist
+ (cons `(apkt . ,(pkt->alist (alist-ref 'pkt res)))
+ res)))
+
+;; NB// ptypes is a list of symbols, '() or #f find all types
+;;
+(define (get-dpkts db ptypes group-id parent-uuid #!key (uuid #f))
+ (let* ((ptype-qry (if (and ptypes
+ (not (null? ptypes)))
+ (conc " IN ('" (string-intersperse (map conc ptypes) "','") "')")
+ (conc " LIKE '%' ")))
+ (rows (dbi:get-rows
+ db
+ (conc
+ "SELECT id,group_id,uuid,parent_uuid,pkt_type,pkt,processed FROM pkts
+ WHERE pkt_type " ptype-qry " AND group_id=?
+ AND processed=0 "
+ (if parent-uuid (conc "AND parent_uuid='" parent-uuid "' ") "")
+ (if uuid (conc "AND uuid='" uuid "' ") "")
+ "ORDER BY id DESC;")
+ group-id)))
+ (map dblst->dpkts (map vector->list rows))))
+
+;; get N pkts not yet processed for group-id
+;;
+(define (get-not-processed-pkts db group-id pkt-type limit offset)
+ (map dblst->dpkts
+ (map vector->list
+ (dbi:get-rows
+ db
+ "SELECT id,group_id,uuid,parent_uuid,pkt_type,pkt,processed FROM pkts
+ WHERE pkt_type = ? AND group_id = ? AND processed=0
+ LIMIT ? OFFSET ?;"
+ (conc pkt-type) ;; convert symbols to string
+ group-id
+ limit
+ offset
+ ))))
+
+;; given a uuid, get not processed child pkts
+;;
+(define (get-related db group-id uuid)
+ (map dblst->dpkts
+ (dbi:get-rows
+ db
+ "SELECT id,group_id,uuid,parent_uuid,pkt_type,pkt,processed FROM pkts
+ WHERE parent_uuid=? AND group_id=? AND processed=0;"
+ uuid group-id)))
+
+;; generic pkt processor
+;;
+;; find all packets in group-id of type in ptypes and apply proc to pktdat
+;;
+(define (process-pkts conn group-id ptypes parent-uuid proc)
+ (let* ((pkts (get-dpkts conn ptypes group-id parent-uuid)))
+ (map proc pkts)))
+
+;; criteria is an alist ((k . valpatt) ...)
+;; - valpatt is a regex
+;; - ptypes is a list of types (symbols expected)
+;; match-type: 'any or 'all
+;;
+(define (find-pkts db ptypes criteria #!key (processed #f)(match-type 'any)(pkt-spec #f)) ;; processed=#f, don't use, else use
+ (let* ((pkts (get-dpkts db ptypes 0 #f))
+ (match-rules (lambda (pktdat) ;; returns a list of matching rules
+ (filter (lambda (c)
+ ;; (print "c: " c)
+ (let* ((ctype (car c)) ;; card type
+ (rx (cdr c)) ;; card pattern
+ ;; (t (alist-ref 'pkt-type pktdat))
+ (pkt (alist-ref 'pkt pktdat))
+ (apkt (pkt->alist pkt))
+ (cdat (alist-ref ctype apkt)))
+ ;; (print "cdat: " cdat) ;; " apkt: " apkt)
+ (if cdat
+ (string-match rx cdat)
+ #f)))
+ criteria)))
+ (res (filter (lambda (pktdat)
+ (if (null? criteria) ;; looking for all pkts
+ #t
+ (case match-type
+ ((any)(not (null? (match-rules pktdat))))
+ ((all)(eq? (length (match-rules pktdat))(length criteria)))
+ (else
+ (print "ERROR: bad match type " match-type ", expecting any or all.")))))
+ pkts)))
+ (if pkt-spec
+ (dpkts->alists res pkt-spec)
+ res)))
+
+;; get descendents of parent-uuid
+;;
+;; NOTE: Should be doing something like the following:
+;;
+;; given a uuid, get not processed child pkts
+;; processed:
+;; #f => get all
+;; 0 => get not processed
+;; 1 => get processed
+;;
+(define (get-ancestors db group-id uuid #!key (processed #f))
+ (map dblst->dpkts
+ (map vector->list
+ (dbi:get-rows
+ db
+ (conc
+ "SELECT id,group_id,uuid,parent_uuid,pkt_type,pkt,processed
+ FROM pkts
+ WHERE uuid IN
+ (WITH RECURSIVE
+ tree(uuid,parent_uuid)
+ AS
+ (
+ SELECT uuid, parent_uuid
+ FROM pkts
+ WHERE uuid = ?
+ UNION ALL
+ SELECT t.uuid, t.parent_uuid
+ FROM pkts t
+ JOIN tree ON t.uuid = tree.parent_uuid
+ )
+ SELECT uuid FROM tree)
+ AND group_id=?" (if processed (conc " AND processed=" processed) "") ";")
+ uuid group-id))))
+
+;; Untested
+;;
+(define (get-descendents db group-id uuid #!key (processed #f))
+ (map dblst->dpkts
+ (map vector->list
+ (dbi:get-rows
+ db
+ (conc
+ "SELECT id,group_id,uuid,parent_uuid,pkt_type,pkt,processed
+ FROM pkts
+ WHERE uuid IN
+ (WITH RECURSIVE
+ tree(uuid,parent_uuid)
+ AS
+ (
+ SELECT uuid, parent_uuid
+ FROM pkts
+ WHERE uuid = ?
+ UNION ALL
+ SELECT t.uuid, t.parent_uuid
+ FROM pkts t
+ JOIN tree ON t.parent_uuid = tree.uuid
+ )
+ SELECT uuid FROM tree)
+ AND group_id=?" (if processed (conc " AND processed=" processed) "") ";")
+ uuid group-id))))
+
+;; look up descendents based on given info unless passed in a list via inlst
+;;
+(define (get-last-descendent db group-id uuid #!key (processed #f)(inlst #f))
+ (let ((descendents (or inlst (get-descendents db group-id uuid processed: processed))))
+ (if (null? descendents)
+ #f
+ (last descendents))))
+
+;;======================================================================
+;; A R C H I V E S - always to a sqlite3 db
+;;======================================================================
+
+;; open an archive db
+;; path: archive-dir//month.db
+;;
+(define (archive-open-db archive-dir)
+ (let* ((curr-time (seconds->local-time (current-seconds)))
+ (dbpath (conc archive-dir "/" (time->string curr-time "%Y")))
+ (dbfile (conc dbpath "/" (time->string curr-time "%m") ".db"))
+ (dbexists (if (file-exists? dbfile) #t (begin (create-directory dbpath #t) #f))))
+ (let ((db (dbi:open 'sqlite3 (list (cons 'dbname dbfile)))))
+ ;; (set-busy-handler! db (busy-timeout 10000))
+ (if (not dbexists) ;; NOTE: In the archive we allow duplicates and other messiness.
+ (dbi:exec db "CREATE TABLE IF NOT EXISTS pkts
+ (id INTEGER,
+ group_id INTEGER,
+ uuid TEXT,
+ parent_uuid TEXT,
+ pkt_type TEXT,
+ pkt TEXT,
+ processed INTEGER DEFAULT 0)"))
+ db)))
+
+;; turn on transactions! otherwise this will be painfully slow
+;;
+(define (write-archive-pkts src-db db pkt-ids)
+ (let ((pkts (dbi:get-rows
+ src-db
+ (conc "SELECT id,group_id,uuid,parent_uuid,pkt_type,pkt FROM pkts WHERE id IN ("
+ (string-intersperse (map conc pkt-ids) ",") ")"))))
+ ;; (dbi:with-transaction
+ ;; db
+ (lambda ()
+ (for-each
+ (lambda (pkt)
+ (apply dbi:exec db "INSERT INTO pkts (id,group_id,uuid,parent_uuid,pkt_type,pkt)
+ VALUES (?,?,?,?,?,?)"
+ pkt))
+ pkts)))) ;; )
+
+;; given a list of uuids and lists of uuids move all to
+;; the sqlite3 db for the current archive period
+;;
+(define (archive-pkts conn pkt-ids archive-dir)
+ (let ((db (archive-open-db archive-dir)))
+ (write-archive-pkts conn db pkt-ids)
+ (dbi:close db))
+ ;; (pg:with-transaction
+ ;; conn
+ ;; (lambda ()
+ (for-each
+ (lambda (id)
+ (dbi:get-one
+ conn
+ "DELETE FROM pkts WHERE id=?" id))
+ pkt-ids)) ;; ))
+
+;; given a list of ids mark all as processed
+;;
+(define (mark-processed conn pkt-ids)
+ ;; (pg:with-transaction
+ ;; conn
+ ;; (lambda ()
+ (for-each
+ (lambda (id)
+ (dbi:get-one
+ conn
+ "UPDATE pkts SET processed=1 WHERE id=?;" id))
+ pkt-ids)) ;; x))
+
+;; a generic pkt getter, gets from the pkts db
+;;
+(define (get-pkts conn ptypes)
+ (let* ((ptypes-str (if (null? ptypes)
+ ""
+ (conc " WHERE pkt_type IN ('" (string-intersperse ptypes ",") "') ")))
+ (qry-str (conc "SELECT id,group_id,uuid,parent_uuid,pkt_type,pkt,processed FROM pkts" ptypes-str)))
+ (map vector->list (dbi:get-rows conn qry-str))))
+
+;; make a report of the pkts in the db
+;; ptypes of '() gets all pkts
+;; display-fields
+;;
+(define (make-report dest conn pktspec display-fields . ptypes)
+ (let* (;; (conn (dbi:db-conn (s:db)))
+ (all-rows (get-pkts conn ptypes))
+ (all-pkts (flatten-all
+ all-rows
+ pktspec
+ 'id 'group-id 'uuid 'parent 'pkt-type 'pkt 'processed))
+ (by-uuid (let ((ht (make-hash-table)))
+ (for-each
+ (lambda (pkt)
+ (let ((uuid (alist-ref 'uuid pkt)))
+ (hash-table-set! ht uuid pkt)))
+ all-pkts)
+ ht))
+ (by-parent (let ((ht (make-hash-table)))
+ (for-each
+ (lambda (pkt)
+ (let ((parent (alist-ref 'parent pkt)))
+ (hash-table-set! ht parent (cons pkt (hash-table-ref/default ht parent '())))))
+ all-pkts)
+ ht))
+ (oup (if dest (open-output-file dest) (current-output-port))))
+
+ (with-output-to-port
+ oup
+ (lambda ()
+ (print "digraph megatest_state_status {
+ // ranksep=0.05
+ rankdir=LR;
+ node [shape=\"box\"];
+")
+ ;; first all the names
+ (for-each
+ (lambda (pkt)
+ (let* ((uuid (alist-ref 'uuid pkt))
+ (shortuuid (substring uuid 0 4))
+ (type (alist-ref 'pkt-type pkt))
+ (processed (alist-ref 'processed pkt)))
+
+ (print "\"" uuid "\" [label=\"" shortuuid ", ("
+ type ", "
+ (if processed "processed" "not processed") ")")
+ (for-each
+ (lambda (key-field)
+ (let ((val (alist-ref key-field pkt)))
+ (if val
+ (print key-field "=" val))))
+ display-fields)
+ (print "\" ];")))
+ all-pkts)
+ ;; now for parent-child relationships
+ (for-each
+ (lambda (pkt)
+ (let ((uuid (alist-ref 'uuid pkt))
+ (parent (alist-ref 'parent pkt)))
+ (if (not (equal? parent ""))
+ (print "\"" parent "\" -> \"" uuid"\";"))))
+ all-pkts)
+
+ (print "}")
+ ))
+ (if dest
+ (begin
+ (close-output-port oup)
+ (system "dot -Tpdf out.dot -o out.pdf")))
+
+ ))
+
+;;======================================================================
+;; Read ref pkts into a vector < laststr hash table >
+;;======================================================================
+
+
+
+;;======================================================================
+;; Read/write packets to files (convience functions)
+;;======================================================================
+
+;; write alist to a pkt file
+;;
+(define (write-alist->pkt targdir dat #!key (pktspec '())(ptype #f))
+ (let-values (((uuid pkt)(alist->pkt dat pktspec ptype: ptype)))
+ (with-output-to-file (conc targdir "/" uuid ".pkt")
+ (lambda ()
+ (print pkt)))
+ uuid)) ;; return the uuid
+
+;; read pkt into alist
+;;
+(define (read-pkt->alist pkt-file #!key (pktspec #f))
+ (pkt->alist (with-input-from-file
+ pkt-file
+ read-string)
+ pktspec: pktspec))
+
+
+) ;; module pkts
ADDED pkts/pkts.setup
Index: pkts/pkts.setup
==================================================================
--- /dev/null
+++ pkts/pkts.setup
@@ -0,0 +1,11 @@
+;; Copyright 2007-2017, 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.
+
+;;;; pkts.setup
+(standard-extension 'pkts "1.0")
ADDED pkts/tests/run.scm
Index: pkts/tests/run.scm
==================================================================
--- /dev/null
+++ pkts/tests/run.scm
@@ -0,0 +1,139 @@
+(use test)
+
+;; (use (prefix pkts pkts:))
+(use pkts (prefix dbi dbi:))
+;; (use trace)(trace sdat->alist pkt->alist)
+
+(if (file-exists? "queue.db")(delete-file "queue.db"))
+
+(test-begin "pkts and pkt archives")
+
+;;======================================================================
+;; Basic pkt creation, parsing and conversion routines
+;;======================================================================
+
+(test-begin "basic packets")
+(test #f '(A "This is a packet") (let-values (((t v)
+ (card->type/value "A This is a packet")))
+ (list t v)))
+(test #f "A A\nZ 664449e7299e0065a3e25c138ccef2df13ba291e"
+ (let-values (((uuid res)
+ (add-z-card '("A A"))))
+ res))
+(test #f '("CC C++" "D 1486332719.0" "a A" "b C")(sort (construct-sdat 'b "C" 'a "A" 'CC "C++" 'D 1486332719.0)
+ string<=?))
+(define pkt-example #f)
+(test #f "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84"
+ (let-values (((uuid res)
+ (construct-pkt 'b "C" 'a "A" 'CC "C++" 'D 1486332719.0)))
+ (set! pkt-example (cons uuid res))
+ res))
+(test-end "basic packets")
+
+;;======================================================================
+;; Sqlite and postgresql based queue of pkts
+;;======================================================================
+
+(test-begin "pkt queue")
+(define db #f)
+(test #f 'sqlite3 (let ((dbh (open-queue-db "." "queue.db")))
+ (set! db dbh)
+ (dbi:db-dbtype dbh)))
+(test #f (cdr pkt-example)
+ (begin
+ (add-to-queue db (cdr pkt-example)(car pkt-example) 'basic #f 0)
+ (lookup-by-uuid db (car pkt-example) 0)))
+(test #f (cdr pkt-example)
+ (lookup-by-id db 1))
+(test #f 1 (length (find-pkts db '(basic) '())))
+
+(test-end "pkt queue")
+
+
+;;======================================================================
+;; Process groups of pkts
+;;======================================================================
+
+(test-begin "lists of packets")
+(test #f '((apkt . #f) (id . 1) (group-id . 2) (uuid . 3) (parent . 4) (pkt-type . 5)) ;; ((id . 1) (group-id . 2) (uuid . 3) (parent . 4) (pkt-type . 5))
+ (dblst->dpkts '(1 2 3 4 5)))
+(test #f '(((apkt (Z . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (b . "C") (a . "A") (D . "1486332719.0") (C . " C++")) (id . 1) (group-id . 0) (uuid . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (parent . "") (pkt-type . "basic") (pkt . "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (processed . 0)))
+ ;; '(((apkt (Z . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (b . "C") (a . "A") (D . "1486332719.0") (C . " C++")) (id . 1) (group-id . 0) (uuid . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (parent . "") (pkt-type . "basic") (pkt . "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84")))
+ ;; '(((id . 1) (group-id . 0) (uuid . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (parent . "") (pkt-type . "basic") (pkt . "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84")))
+ (get-dpkts db '(basic) 0 #f))
+(test #f '(((apkt (Z . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (b . "C") (a . "A") (D . "1486332719.0") (C . " C++")) (id . 1) (group-id . 0) (uuid . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (parent . "") (pkt-type . "basic") (pkt . "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (processed . 0)))
+ ;; '(((apkt (Z . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (b . "C") (a . "A") (D . "1486332719.0") (C . " C++")) (id . 1) (group-id . 0) (uuid . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (parent . "") (pkt-type . "basic") (pkt . "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84")))
+ ;; '(((id . 1) (group-id . 0) (uuid . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (parent . "") (pkt-type . "basic") (pkt . "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84")))
+ (get-not-processed-pkts db 0 'basic 1000 0))
+(test-end "lists of packets")
+
+(test-begin "pkts as alists")
+(define pktspec '((posting . ((title . t) ;; NOTE: same as ((posting (title . t)(url . u)(blub . b)) ...
+ (url . u)
+ (blurb . b)))
+ (comment . ((comment . c)
+ (score . s)))
+ (basic . ((b-field . b)
+ (a-field . a)))))
+(define pktlst (find-pkts db '(basic) '()))
+(define dpkt (car pktlst))
+(test #f "A" (get-value 'a-field dpkt pktspec))
+
+(test #f "C" (alist-ref 'b-field (dpkt->alist dpkt pktspec)))
+
+(define basic-spec '((nada (foo . b)(bar . f))(basic (foo . f)(bar . b))))
+(define test-pkt '((foo . "fooval")(bar . "barval")))
+(let*-values (((u p) (alist->pkt test-pkt basic-spec ptype: 'basic))
+ ((apkt) (pkt->alist p))
+ ((bpkt) (pkt->alist p pktspec: basic-spec)))
+ (test #f "fooval" (alist-ref 'f apkt))
+ (test #f "fooval" (alist-ref 'foo bpkt))
+ (test #f #f (alist-ref 'f bpkt)))
+
+(test-end "pkts as alists")
+
+(test-begin "descendents and ancestors")
+
+(define (get-uuid pkt)(alist-ref 'uuid pkt))
+
+;; add a child to 263e
+(let-values (((uuid pkt)
+ (construct-pkt 'x "X" 'y "Y" 'P "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84"
+ 'D "1486332719.0")))
+ (add-to-queue db pkt uuid 'basic "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84" 0))
+
+(test #f '("263eb3b6193de7fe65b1ded5bcda513e8b4d6b84" "818fe30988c9673441b8f203972a8bda6af682f8")
+ (map (lambda (x)(alist-ref 'uuid x))
+ (get-descendents
+ db 0
+ "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84")))
+
+(test #f '("263eb3b6193de7fe65b1ded5bcda513e8b4d6b84" "818fe30988c9673441b8f203972a8bda6af682f8")
+ (map (lambda (x)(alist-ref 'uuid x))
+ (get-ancestors
+ db 0
+ "818fe30988c9673441b8f203972a8bda6af682f8")))
+
+(test-end "descendents and ancestors")
+
+(test-end "pkts and pkt archives")
+
+(test-begin "pktsdb")
+
+(define spec '((tests (testname n TEXT)
+ (testpath p TEXT)
+ (duration d INTEGER))))
+;; (define pktsdb (make-pktdb))
+;; (pktdb-pktsdb-spec-set! pktsdb spec)
+
+(define pktsdb #f)
+
+(test #f #t (dbi:database? (let ((pdb (pktsdb-open "test.db" spec)))
+ (set! pktsdb pdb)
+ (pktdb-conn pdb))))
+;; (pp (pktdb-pktspec pktsdb))
+(test #f #t (pktsdb-add-record pktsdb 'tests '((testname . "test1"))))
+
+(pktsdb-close pktsdb)
+
+(test-end "pktsdb")
Index: rmt.scm
==================================================================
--- rmt.scm
+++ rmt.scm
@@ -558,10 +558,13 @@
;; (begin
;; (debug:print-error 0 *default-log-port* "rmt:get-tests-for-run called with bad run-id=" run-id)
;; (print-call-chain (current-error-port))
;; '())))
+(define (rmt:get-tests-for-run-state-status run-id testpatt last-update)
+ (rmt:send-receive 'get-tests-for-run-state-status run-id (list run-id testpatt last-update)))
+
;; get stuff via synchash
(define (rmt:synchash-get run-id proc synckey keynum params)
(rmt:send-receive 'synchash-get run-id (list run-id proc synckey keynum params)))
(define (rmt:get-tests-for-run-mindata run-id testpatt states status not-in)
@@ -735,12 +738,12 @@
(rmt:send-receive 'delete-old-deleted-test-records #f '()))
(define (rmt:get-runs runpatt count offset keypatts)
(rmt:send-receive 'get-runs #f (list runpatt count offset keypatts)))
-(define (rmt:simple-get-runs runpatt count offset target)
- (rmt:send-receive 'simple-get-runs #f (list runpatt count offset target)))
+(define (rmt:simple-get-runs runpatt count offset target last-update)
+ (rmt:send-receive 'simple-get-runs #f (list runpatt count offset target last-update)))
(define (rmt:get-all-run-ids)
(rmt:send-receive 'get-all-run-ids #f '()))
(define (rmt:get-prev-run-ids run-id)
Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -2012,11 +2012,11 @@
(let* ((targets (string-split target-patts ","))
(keys (rmt:get-keys))
(res-ht (make-hash-table))) ;; target -> ( runrecord1 runrecord2 ... )
(for-each
(lambda (target-patt)
- (let ((runs (rmt:simple-get-runs runpatt #f #f target-patt)))
+ (let ((runs (rmt:simple-get-runs runpatt #f #f target-patt #f)))
(for-each
(lambda (run)
(let ((target (simple-run-target run)))
(hash-table-set! res-ht target (cons run (hash-table-ref/default res-ht target '())))))
runs)))
ADDED stml2.scm
Index: stml2.scm
==================================================================
--- /dev/null
+++ stml2.scm
@@ -0,0 +1,23 @@
+;;======================================================================
+;; Copyright 2019, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+;;======================================================================
+
+(declare (unit stml2))
+
+(include "stml2/stml2.scm")
ADDED stml2/COPYING
Index: stml2/COPYING
==================================================================
--- /dev/null
+++ stml2/COPYING
@@ -0,0 +1,724 @@
+ GNU GENERAL PUBLIC LICENSE
+ Version 2, June 1991
+
+ Copyright (C) 1989, 1991 Free Software Foundation, Inc.
+ 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+ Preamble
+
+ The licenses for most software are designed to take away your
+freedom to share and change it. By contrast, the GNU General Public
+License is intended to guarantee your freedom to share and change free
+software--to make sure the software is free for all its users. This
+General Public License applies to most of the Free Software
+Foundation's software and to any other program whose authors commit to
+using it. (Some other Free Software Foundation software is covered by
+the GNU Library General Public License instead.) You can apply it to
+your programs, too.
+
+ When we speak of free software, we are referring to freedom, not
+price. Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+this service if you wish), that you receive source code or can get it
+if you want it, that you can change the software or use pieces of it
+in new free programs; and that you know you can do these things.
+
+ To protect your rights, we need to make restrictions that forbid
+anyone to deny you these rights or to ask you to surrender the rights.
+These restrictions translate to certain responsibilities for you if you
+distribute copies of the software, or if you modify it.
+
+ For example, if you distribute copies of such a program, whether
+gratis or for a fee, you must give the recipients all the rights that
+you have. You must make sure that they, too, receive or can get the
+source code. And you must show them these terms so they know their
+rights.
+
+ We protect your rights with two steps: (1) copyright the software, and
+(2) offer you this license which gives you legal permission to copy,
+distribute and/or modify the software.
+
+ Also, for each author's protection and ours, we want to make certain
+that everyone understands that there is no warranty for this free
+software. If the software is modified by someone else and passed on, we
+want its recipients to know that what they have is not the original, so
+that any problems introduced by others will not reflect on the original
+authors' reputations.
+
+ Finally, any free program is threatened constantly by software
+patents. We wish to avoid the danger that redistributors of a free
+program will individually obtain patent licenses, in effect making the
+program proprietary. To prevent this, we have made it clear that any
+patent must be licensed for everyone's free use or not licensed at all.
+
+ The precise terms and conditions for copying, distribution and
+modification follow.
+
+ GNU GENERAL PUBLIC LICENSE
+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+ 0. This License applies to any program or other work which contains
+a notice placed by the copyright holder saying it may be distributed
+under the terms of this General Public License. The "Program", below,
+refers to any such program or work, and a "work based on the Program"
+means either the Program or any derivative work under copyright law:
+that is to say, a work containing the Program or a portion of it,
+either verbatim or with modifications and/or translated into another
+language. (Hereinafter, translation is included without limitation in
+the term "modification".) Each licensee is addressed as "you".
+
+Activities other than copying, distribution and modification are not
+covered by this License; they are outside its scope. The act of
+running the Program is not restricted, and the output from the Program
+is covered only if its contents constitute a work based on the
+Program (independent of having been made by running the Program).
+Whether that is true depends on what the Program does.
+
+ 1. You may copy and distribute verbatim copies of the Program's
+source code as you receive it, in any medium, provided that you
+conspicuously and appropriately publish on each copy an appropriate
+copyright notice and disclaimer of warranty; keep intact all the
+notices that refer to this License and to the absence of any warranty;
+and give any other recipients of the Program a copy of this License
+along with the Program.
+
+You may charge a fee for the physical act of transferring a copy, and
+you may at your option offer warranty protection in exchange for a fee.
+
+ 2. You may modify your copy or copies of the Program or any portion
+of it, thus forming a work based on the Program, and copy and
+distribute such modifications or work under the terms of Section 1
+above, provided that you also meet all of these conditions:
+
+ a) You must cause the modified files to carry prominent notices
+ stating that you changed the files and the date of any change.
+
+ b) You must cause any work that you distribute or publish, that in
+ whole or in part contains or is derived from the Program or any
+ part thereof, to be licensed as a whole at no charge to all third
+ parties under the terms of this License.
+
+ c) If the modified program normally reads commands interactively
+ when run, you must cause it, when started running for such
+ interactive use in the most ordinary way, to print or display an
+ announcement including an appropriate copyright notice and a
+ notice that there is no warranty (or else, saying that you provide
+ a warranty) and that users may redistribute the program under
+ these conditions, and telling the user how to view a copy of this
+ License. (Exception: if the Program itself is interactive but
+ does not normally print such an announcement, your work based on
+ the Program is not required to print an announcement.)
+
+These requirements apply to the modified work as a whole. If
+identifiable sections of that work are not derived from the Program,
+and can be reasonably considered independent and separate works in
+themselves, then this License, and its terms, do not apply to those
+sections when you distribute them as separate works. But when you
+distribute the same sections as part of a whole which is a work based
+on the Program, the distribution of the whole must be on the terms of
+this License, whose permissions for other licensees extend to the
+entire whole, and thus to each and every part regardless of who wrote it.
+
+Thus, it is not the intent of this section to claim rights or contest
+your rights to work written entirely by you; rather, the intent is to
+exercise the right to control the distribution of derivative or
+collective works based on the Program.
+
+In addition, mere aggregation of another work not based on the Program
+with the Program (or with a work based on the Program) on a volume of
+a storage or distribution medium does not bring the other work under
+the scope of this License.
+
+ 3. You may copy and distribute the Program (or a work based on it,
+under Section 2) in object code or executable form under the terms of
+Sections 1 and 2 above provided that you also do one of the following:
+
+ a) Accompany it with the complete corresponding machine-readable
+ source code, which must be distributed under the terms of Sections
+ 1 and 2 above on a medium customarily used for software interchange; or,
+
+ b) Accompany it with a written offer, valid for at least three
+ years, to give any third party, for a charge no more than your
+ cost of physically performing source distribution, a complete
+ machine-readable copy of the corresponding source code, to be
+ distributed under the terms of Sections 1 and 2 above on a medium
+ customarily used for software interchange; or,
+
+ c) Accompany it with the information you received as to the offer
+ to distribute corresponding source code. (This alternative is
+ allowed only for noncommercial distribution and only if you
+ received the program in object code or executable form with such
+ an offer, in accord with Subsection b above.)
+
+The source code for a work means the preferred form of the work for
+making modifications to it. For an executable work, complete source
+code means all the source code for all modules it contains, plus any
+associated interface definition files, plus the scripts used to
+control compilation and installation of the executable. However, as a
+special exception, the source code distributed need not include
+anything that is normally distributed (in either source or binary
+form) with the major components (compiler, kernel, and so on) of the
+operating system on which the executable runs, unless that component
+itself accompanies the executable.
+
+If distribution of executable or object code is made by offering
+access to copy from a designated place, then offering equivalent
+access to copy the source code from the same place counts as
+distribution of the source code, even though third parties are not
+compelled to copy the source along with the object code.
+
+ 4. You may not copy, modify, sublicense, or distribute the Program
+except as expressly provided under this License. Any attempt
+otherwise to copy, modify, sublicense or distribute the Program is
+void, and will automatically terminate your rights under this License.
+However, parties who have received copies, or rights, from you under
+this License will not have their licenses terminated so long as such
+parties remain in full compliance.
+
+ 5. You are not required to accept this License, since you have not
+signed it. However, nothing else grants you permission to modify or
+distribute the Program or its derivative works. These actions are
+prohibited by law if you do not accept this License. Therefore, by
+modifying or distributing the Program (or any work based on the
+Program), you indicate your acceptance of this License to do so, and
+all its terms and conditions for copying, distributing or modifying
+the Program or works based on it.
+
+ 6. Each time you redistribute the Program (or any work based on the
+Program), the recipient automatically receives a license from the
+original licensor to copy, distribute or modify the Program subject to
+these terms and conditions. You may not impose any further
+restrictions on the recipients' exercise of the rights granted herein.
+You are not responsible for enforcing compliance by third parties to
+this License.
+
+ 7. If, as a consequence of a court judgment or allegation of patent
+infringement or for any other reason (not limited to patent issues),
+conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License. If you cannot
+distribute so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you
+may not distribute the Program at all. For example, if a patent
+license would not permit royalty-free redistribution of the Program by
+all those who receive copies directly or indirectly through you, then
+the only way you could satisfy both it and this License would be to
+refrain entirely from distribution of the Program.
+
+If any portion of this section is held invalid or unenforceable under
+any particular circumstance, the balance of the section is intended to
+apply and the section as a whole is intended to apply in other
+circumstances.
+
+It is not the purpose of this section to induce you to infringe any
+patents or other property right claims or to contest validity of any
+such claims; this section has the sole purpose of protecting the
+integrity of the free software distribution system, which is
+implemented by public license practices. Many people have made
+generous contributions to the wide range of software distributed
+through that system in reliance on consistent application of that
+system; it is up to the author/donor to decide if he or she is willing
+to distribute software through any other system and a licensee cannot
+impose that choice.
+
+This section is intended to make thoroughly clear what is believed to
+be a consequence of the rest of this License.
+
+ 8. If the distribution and/or use of the Program is restricted in
+certain countries either by patents or by copyrighted interfaces, the
+original copyright holder who places the Program under this License
+may add an explicit geographical distribution limitation excluding
+those countries, so that distribution is permitted only in or among
+countries not thus excluded. In such case, this License incorporates
+the limitation as if written in the body of this License.
+
+ 9. The Free Software Foundation may publish revised and/or new versions
+of the General Public License from time to time. Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+Each version is given a distinguishing version number. If the Program
+specifies a version number of this License which applies to it and "any
+later version", you have the option of following the terms and conditions
+either of that version or of any later version published by the Free
+Software Foundation. If the Program does not specify a version number of
+this License, you may choose any version ever published by the Free Software
+Foundation.
+
+ 10. If you wish to incorporate parts of the Program into other free
+programs whose distribution conditions are different, write to the author
+to ask for permission. For software which is copyrighted by the Free
+Software Foundation, write to the Free Software Foundation; we sometimes
+make exceptions for this. Our decision will be guided by the two goals
+of preserving the free status of all derivatives of our free software and
+of promoting the sharing and reuse of software generally.
+
+ NO WARRANTY
+
+ 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
+REPAIR OR CORRECTION.
+
+ 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGES.
+
+ END OF TERMS AND CONDITIONS
+
+ How to Apply These Terms to Your New Programs
+
+ If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+ To do so, attach the following notices to the program. It is safest
+to attach them to the start of each source file to most effectively
+convey the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+
+ Copyright (C)
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+
+
+Also add information on how to contact you by electronic and paper mail.
+
+If the program is interactive, make it output a short notice like this
+when it starts in an interactive mode:
+
+ Gnomovision version 69, Copyright (C) year name of author
+ Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+ This is free software, and you are welcome to redistribute it
+ under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the appropriate
+parts of the General Public License. Of course, the commands you use may
+be called something other than `show w' and `show c'; they could even be
+mouse-clicks or menu items--whatever suits your program.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the program, if
+necessary. Here is a sample; alter the names:
+
+ Yoyodyne, Inc., hereby disclaims all copyright interest in the program
+ `Gnomovision' (which makes passes at compilers) written by James Hacker.
+
+ , 1 April 1989
+ Ty Coon, President of Vice
+
+This General Public License does not permit incorporating your program into
+proprietary programs. If your program is a subroutine library, you may
+consider it more useful to permit linking proprietary applications with the
+library. If this is what you want to do, use the GNU Library General
+Public License instead of this License.
+
+
+GNU Free Documentation License
+******************************
+
+ Version 1.1, March 2000
+ Copyright (C) 2000 Free Software Foundation, Inc.
+ 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+ 0. PREAMBLE
+
+ The purpose of this License is to make a manual, textbook, or other
+ written document "free" in the sense of freedom: to assure everyone
+ the effective freedom to copy and redistribute it, with or without
+ modifying it, either commercially or noncommercially. Secondarily,
+ this License preserves for the author and publisher a way to get
+ credit for their work, while not being considered responsible for
+ modifications made by others.
+
+ This License is a kind of "copyleft", which means that derivative
+ works of the document must themselves be free in the same sense.
+ It complements the GNU General Public License, which is a copyleft
+ license designed for free software.
+
+ We have designed this License in order to use it for manuals for
+ free software, because free software needs free documentation: a
+ free program should come with manuals providing the same freedoms
+ that the software does. But this License is not limited to
+ software manuals; it can be used for any textual work, regardless
+ of subject matter or whether it is published as a printed book.
+ We recommend this License principally for works whose purpose is
+ instruction or reference.
+
+ 1. APPLICABILITY AND DEFINITIONS
+
+ This License applies to any manual or other work that contains a
+ notice placed by the copyright holder saying it can be distributed
+ under the terms of this License. The "Document", below, refers to
+ any such manual or work. Any member of the public is a licensee,
+ and is addressed as "you".
+
+ A "Modified Version" of the Document means any work containing the
+ Document or a portion of it, either copied verbatim, or with
+ modifications and/or translated into another language.
+
+ A "Secondary Section" is a named appendix or a front-matter
+ section of the Document that deals exclusively with the
+ relationship of the publishers or authors of the Document to the
+ Document's overall subject (or to related matters) and contains
+ nothing that could fall directly within that overall subject.
+ (For example, if the Document is in part a textbook of
+ mathematics, a Secondary Section may not explain any mathematics.)
+ The relationship could be a matter of historical connection with
+ the subject or with related matters, or of legal, commercial,
+ philosophical, ethical or political position regarding them.
+
+ The "Invariant Sections" are certain Secondary Sections whose
+ titles are designated, as being those of Invariant Sections, in
+ the notice that says that the Document is released under this
+ License.
+
+ The "Cover Texts" are certain short passages of text that are
+ listed, as Front-Cover Texts or Back-Cover Texts, in the notice
+ that says that the Document is released under this License.
+
+ A "Transparent" copy of the Document means a machine-readable copy,
+ represented in a format whose specification is available to the
+ general public, whose contents can be viewed and edited directly
+ and straightforwardly with generic text editors or (for images
+ composed of pixels) generic paint programs or (for drawings) some
+ widely available drawing editor, and that is suitable for input to
+ text formatters or for automatic translation to a variety of
+ formats suitable for input to text formatters. A copy made in an
+ otherwise Transparent file format whose markup has been designed
+ to thwart or discourage subsequent modification by readers is not
+ Transparent. A copy that is not "Transparent" is called "Opaque".
+
+ Examples of suitable formats for Transparent copies include plain
+ ASCII without markup, Texinfo input format, LaTeX input format,
+ SGML or XML using a publicly available DTD, and
+ standard-conforming simple HTML designed for human modification.
+ Opaque formats include PostScript, PDF, proprietary formats that
+ can be read and edited only by proprietary word processors, SGML
+ or XML for which the DTD and/or processing tools are not generally
+ available, and the machine-generated HTML produced by some word
+ processors for output purposes only.
+
+ The "Title Page" means, for a printed book, the title page itself,
+ plus such following pages as are needed to hold, legibly, the
+ material this License requires to appear in the title page. For
+ works in formats which do not have any title page as such, "Title
+ Page" means the text near the most prominent appearance of the
+ work's title, preceding the beginning of the body of the text.
+
+ 2. VERBATIM COPYING
+
+ You may copy and distribute the Document in any medium, either
+ commercially or noncommercially, provided that this License, the
+ copyright notices, and the license notice saying this License
+ applies to the Document are reproduced in all copies, and that you
+ add no other conditions whatsoever to those of this License. You
+ may not use technical measures to obstruct or control the reading
+ or further copying of the copies you make or distribute. However,
+ you may accept compensation in exchange for copies. If you
+ distribute a large enough number of copies you must also follow
+ the conditions in section 3.
+
+ You may also lend copies, under the same conditions stated above,
+ and you may publicly display copies.
+
+ 3. COPYING IN QUANTITY
+
+ If you publish printed copies of the Document numbering more than
+ 100, and the Document's license notice requires Cover Texts, you
+ must enclose the copies in covers that carry, clearly and legibly,
+ all these Cover Texts: Front-Cover Texts on the front cover, and
+ Back-Cover Texts on the back cover. Both covers must also clearly
+ and legibly identify you as the publisher of these copies. The
+ front cover must present the full title with all words of the
+ title equally prominent and visible. You may add other material
+ on the covers in addition. Copying with changes limited to the
+ covers, as long as they preserve the title of the Document and
+ satisfy these conditions, can be treated as verbatim copying in
+ other respects.
+
+ If the required texts for either cover are too voluminous to fit
+ legibly, you should put the first ones listed (as many as fit
+ reasonably) on the actual cover, and continue the rest onto
+ adjacent pages.
+
+ If you publish or distribute Opaque copies of the Document
+ numbering more than 100, you must either include a
+ machine-readable Transparent copy along with each Opaque copy, or
+ state in or with each Opaque copy a publicly-accessible
+ computer-network location containing a complete Transparent copy
+ of the Document, free of added material, which the general
+ network-using public has access to download anonymously at no
+ charge using public-standard network protocols. If you use the
+ latter option, you must take reasonably prudent steps, when you
+ begin distribution of Opaque copies in quantity, to ensure that
+ this Transparent copy will remain thus accessible at the stated
+ location until at least one year after the last time you
+ distribute an Opaque copy (directly or through your agents or
+ retailers) of that edition to the public.
+
+ It is requested, but not required, that you contact the authors of
+ the Document well before redistributing any large number of
+ copies, to give them a chance to provide you with an updated
+ version of the Document.
+
+ 4. MODIFICATIONS
+
+ You may copy and distribute a Modified Version of the Document
+ under the conditions of sections 2 and 3 above, provided that you
+ release the Modified Version under precisely this License, with
+ the Modified Version filling the role of the Document, thus
+ licensing distribution and modification of the Modified Version to
+ whoever possesses a copy of it. In addition, you must do these
+ things in the Modified Version:
+
+ A. Use in the Title Page (and on the covers, if any) a title
+ distinct from that of the Document, and from those of
+ previous versions (which should, if there were any, be listed
+ in the History section of the Document). You may use the
+ same title as a previous version if the original publisher of
+ that version gives permission.
+
+ B. List on the Title Page, as authors, one or more persons or
+ entities responsible for authorship of the modifications in
+ the Modified Version, together with at least five of the
+ principal authors of the Document (all of its principal
+ authors, if it has less than five).
+
+ C. State on the Title page the name of the publisher of the
+ Modified Version, as the publisher.
+
+ D. Preserve all the copyright notices of the Document.
+
+ E. Add an appropriate copyright notice for your modifications
+ adjacent to the other copyright notices.
+
+ F. Include, immediately after the copyright notices, a license
+ notice giving the public permission to use the Modified
+ Version under the terms of this License, in the form shown in
+ the Addendum below.
+
+ G. Preserve in that license notice the full lists of Invariant
+ Sections and required Cover Texts given in the Document's
+ license notice.
+
+ H. Include an unaltered copy of this License.
+
+ I. Preserve the section entitled "History", and its title, and
+ add to it an item stating at least the title, year, new
+ authors, and publisher of the Modified Version as given on
+ the Title Page. If there is no section entitled "History" in
+ the Document, create one stating the title, year, authors,
+ and publisher of the Document as given on its Title Page,
+ then add an item describing the Modified Version as stated in
+ the previous sentence.
+
+ J. Preserve the network location, if any, given in the Document
+ for public access to a Transparent copy of the Document, and
+ likewise the network locations given in the Document for
+ previous versions it was based on. These may be placed in
+ the "History" section. You may omit a network location for a
+ work that was published at least four years before the
+ Document itself, or if the original publisher of the version
+ it refers to gives permission.
+
+ K. In any section entitled "Acknowledgments" or "Dedications",
+ preserve the section's title, and preserve in the section all
+ the substance and tone of each of the contributor
+ acknowledgments and/or dedications given therein.
+
+ L. Preserve all the Invariant Sections of the Document,
+ unaltered in their text and in their titles. Section numbers
+ or the equivalent are not considered part of the section
+ titles.
+
+ M. Delete any section entitled "Endorsements". Such a section
+ may not be included in the Modified Version.
+
+ N. Do not retitle any existing section as "Endorsements" or to
+ conflict in title with any Invariant Section.
+
+ If the Modified Version includes new front-matter sections or
+ appendices that qualify as Secondary Sections and contain no
+ material copied from the Document, you may at your option
+ designate some or all of these sections as invariant. To do this,
+ add their titles to the list of Invariant Sections in the Modified
+ Version's license notice. These titles must be distinct from any
+ other section titles.
+
+ You may add a section entitled "Endorsements", provided it contains
+ nothing but endorsements of your Modified Version by various
+ parties--for example, statements of peer review or that the text
+ has been approved by an organization as the authoritative
+ definition of a standard.
+
+ You may add a passage of up to five words as a Front-Cover Text,
+ and a passage of up to 25 words as a Back-Cover Text, to the end
+ of the list of Cover Texts in the Modified Version. Only one
+ passage of Front-Cover Text and one of Back-Cover Text may be
+ added by (or through arrangements made by) any one entity. If the
+ Document already includes a cover text for the same cover,
+ previously added by you or by arrangement made by the same entity
+ you are acting on behalf of, you may not add another; but you may
+ replace the old one, on explicit permission from the previous
+ publisher that added the old one.
+
+ The author(s) and publisher(s) of the Document do not by this
+ License give permission to use their names for publicity for or to
+ assert or imply endorsement of any Modified Version.
+
+ 5. COMBINING DOCUMENTS
+
+ You may combine the Document with other documents released under
+ this License, under the terms defined in section 4 above for
+ modified versions, provided that you include in the combination
+ all of the Invariant Sections of all of the original documents,
+ unmodified, and list them all as Invariant Sections of your
+ combined work in its license notice.
+
+ The combined work need only contain one copy of this License, and
+ multiple identical Invariant Sections may be replaced with a single
+ copy. If there are multiple Invariant Sections with the same name
+ but different contents, make the title of each such section unique
+ by adding at the end of it, in parentheses, the name of the
+ original author or publisher of that section if known, or else a
+ unique number. Make the same adjustment to the section titles in
+ the list of Invariant Sections in the license notice of the
+ combined work.
+
+ In the combination, you must combine any sections entitled
+ "History" in the various original documents, forming one section
+ entitled "History"; likewise combine any sections entitled
+ "Acknowledgments", and any sections entitled "Dedications". You
+ must delete all sections entitled "Endorsements."
+
+ 6. COLLECTIONS OF DOCUMENTS
+
+ You may make a collection consisting of the Document and other
+ documents released under this License, and replace the individual
+ copies of this License in the various documents with a single copy
+ that is included in the collection, provided that you follow the
+ rules of this License for verbatim copying of each of the
+ documents in all other respects.
+
+ You may extract a single document from such a collection, and
+ distribute it individually under this License, provided you insert
+ a copy of this License into the extracted document, and follow
+ this License in all other respects regarding verbatim copying of
+ that document.
+
+ 7. AGGREGATION WITH INDEPENDENT WORKS
+
+ A compilation of the Document or its derivatives with other
+ separate and independent documents or works, in or on a volume of
+ a storage or distribution medium, does not as a whole count as a
+ Modified Version of the Document, provided no compilation
+ copyright is claimed for the compilation. Such a compilation is
+ called an "aggregate", and this License does not apply to the
+ other self-contained works thus compiled with the Document, on
+ account of their being thus compiled, if they are not themselves
+ derivative works of the Document.
+
+ If the Cover Text requirement of section 3 is applicable to these
+ copies of the Document, then if the Document is less than one
+ quarter of the entire aggregate, the Document's Cover Texts may be
+ placed on covers that surround only the Document within the
+ aggregate. Otherwise they must appear on covers around the whole
+ aggregate.
+
+ 8. TRANSLATION
+
+ Translation is considered a kind of modification, so you may
+ distribute translations of the Document under the terms of section
+ 4. Replacing Invariant Sections with translations requires special
+ permission from their copyright holders, but you may include
+ translations of some or all Invariant Sections in addition to the
+ original versions of these Invariant Sections. You may include a
+ translation of this License provided that you also include the
+ original English version of this License. In case of a
+ disagreement between the translation and the original English
+ version of this License, the original English version will prevail.
+
+ 9. TERMINATION
+
+ You may not copy, modify, sublicense, or distribute the Document
+ except as expressly provided for under this License. Any other
+ attempt to copy, modify, sublicense or distribute the Document is
+ void, and will automatically terminate your rights under this
+ License. However, parties who have received copies, or rights,
+ from you under this License will not have their licenses
+ terminated so long as such parties remain in full compliance.
+
+ 10. FUTURE REVISIONS OF THIS LICENSE
+
+ The Free Software Foundation may publish new, revised versions of
+ the GNU Free Documentation License from time to time. Such new
+ versions will be similar in spirit to the present version, but may
+ differ in detail to address new problems or concerns. See
+ `http://www.gnu.org/copyleft/'.
+
+ Each version of the License is given a distinguishing version
+ number. If the Document specifies that a particular numbered
+ version of this License "or any later version" applies to it, you
+ have the option of following the terms and conditions either of
+ that specified version or of any later version that has been
+ published (not as a draft) by the Free Software Foundation. If
+ the Document does not specify a version number of this License,
+ you may choose any version ever published (not as a draft) by the
+ Free Software Foundation.
+
+ADDENDUM: How to use this License for your documents
+----------------------------------------------------
+
+ To use this License in a document you have written, include a copy of
+the License in the document and put the following copyright and license
+notices just after the title page:
+
+ Copyright (C) YEAR YOUR NAME.
+ Permission is granted to copy, distribute and/or modify this document
+ under the terms of the GNU Free Documentation License, Version 1.1
+ or any later version published by the Free Software Foundation;
+ with the Invariant Sections being LIST THEIR TITLES, with the
+ Front-Cover Texts being LIST, and with the Back-Cover Texts being LIST.
+ A copy of the license is included in the section entitled ``GNU
+ Free Documentation License''.
+
+ If you have no Invariant Sections, write "with no Invariant Sections"
+instead of saying which ones are invariant. If you have no Front-Cover
+Texts, write "no Front-Cover Texts" instead of "Front-Cover Texts being
+LIST"; likewise for Back-Cover Texts.
+
+ If your document contains nontrivial examples of program code, we
+recommend releasing these examples in parallel under your choice of
+free software license, such as the GNU General Public License, to
+permit their use in free software.
+
ADDED stml2/INSTALL
Index: stml2/INSTALL
==================================================================
--- /dev/null
+++ stml2/INSTALL
@@ -0,0 +1,23 @@
+These are rough installation instructions. Please contact me at matt@kiatoa.com
+if you have trouble installing.
+
+1. Copy install.cfg.template to install.cfg and modify appropriately
+
+2. Copy stml.config.template to your cgi dir as .stml.config and modify appropriately
+ - choose your db
+
+3. Copy requirements.scm.template to requirements.scm and modify as needed
+ - choose your db (must match what you choose in 2. above)
+
+If on 64 bit and you get error in compiling try fPIC:
+
+CSC_OPTIONS='-C "-fPIC"' make
+
+run
+
+> make
+
+or
+
+> CSC_OPTIONS='-C "-fPIC"' make
+
ADDED stml2/Makefile
Index: stml2/Makefile
==================================================================
--- /dev/null
+++ stml2/Makefile
@@ -0,0 +1,88 @@
+# 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 = stml2.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 stml2.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 stmlcommon.scm
+ csc $(CSCOPTS) $(OFILES) stmlrun.scm -o stmlrun
+
+stml.so : stmlmodule.so
+ cp stmlmodule.so stml.so
+
+stmlmodule.so : $(OFILES) stmlmodule.scm requirements.scm stmlcommon.scm
+ csc $(CSCOPTS) $(OFILES) -s stmlmodule.scm
+
+# logging currently relies on this
+#
+$(LOGDIR) :
+ mkdir -p $(LOGDIR)
+ chmod a+rwx $(LOGDIR)
+
+test: kiatoa.db cookie.so
+ echo '(exit)'| csi -q ./tests/test.scm
+
+# modules
+#
+%.so : %.scm
+ csc $(CSCOPTS) -I modules/* -s $<
+
+%.o : %.scm
+ csc $(CSCOPTS) -c $<
+
+# Cookie is a special case for now. Make a loadable so for test
+# Complile it in by include (see dependencies above).
+cookie.so : cookie.scm
+ csc i$(CSCOPTS) -s cookie.scm
+
+clean :
+ rm -f doc/*~ modules/*/*.so *.import.scm *.import.so *.o *.so *~
+
+# $(CFILES): build/%.c: ../scm/%.scm ../scm/macros.scm
+# chicken $< -output-file $@
+#
+#
+# $(OFILES): src/%.o: src/%.c
+# gcc -c $< `chicken-config -cflags` -o $@
+#
+# $(src_code): %: src/%.o src/laedlib.o src/layobj.o
+# gcc src/$*.o src/laedlib.o src/layobj.o -o $* `chicken-config -libs`
+#
ADDED stml2/README
Index: stml2/README
==================================================================
--- /dev/null
+++ stml2/README
@@ -0,0 +1,1 @@
+This is the stml, scheme based cgi application framework.
ADDED stml2/TODO
Index: stml2/TODO
==================================================================
--- /dev/null
+++ stml2/TODO
@@ -0,0 +1,22 @@
+1. Documentation.
+ multiple apps in same cgi dir
+ compilation of models for speed and code protection
+ tricks
+2. Hierarchial pages. Currently pages can be hierarchial but the control.scm
+ doesn't get called at the right time.
+3. For sqlite3 usage put session into own db?
+4. A mechanism for sharing variables better between control and view
+ would be good.
+ Perhaps:
+ (let ()
+ (load control)
+ (load view))
+5. Change all the "included" files to be seperately compiled units
+ and adj. makefile accordingly. This would speed up compilation
+ when changes are isolated to one or two files.
+6. The dbi interface needs a simple config mecanism alternative to
+ the current list of pairs which is hard to use on the fly.
+ Something like the perl:
+ "dbi:host:port:user:password"
+
+I'm sure there is more ...
ADDED stml2/cookie.scm
Index: stml2/cookie.scm
==================================================================
--- /dev/null
+++ stml2/cookie.scm
@@ -0,0 +1,264 @@
+;;;
+;;; cookie.scm - parse and construct http state information
+;;;
+;;; Copyright (c) 2000-2003 Shiro Kawai, All rights reserved.
+;;;
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;;
+;;; 1. Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+;;;
+;;; 2. Redistributions in binary form must reproduce the above copyright
+;;; notice, this list of conditions and the following disclaimer in the
+;;; documentation and/or other materials provided with the distribution.
+;;;
+;;; 3. Neither the name of the authors nor the names of its contributors
+;;; may be used to endorse or promote products derived from this
+;;; software without specific prior written permission.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
+;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;;;
+;;; Ported to Chicken by Reed Sheridan
+;;;
+
+;; Parser and constructor of http "Cookies" defined in
+;; RFC 2965 HTTP state managemnet mechanism
+;;
+;; See also
+;; RFC 2964 Use of HTTP state management
+;;
+;; The parser also supports the old Netscape spec
+;;
+
+;; (declare (unit cookie))
+
+(module cookie
+ *
+
+(import chicken scheme data-structures extras srfi-13 ports posix)
+
+(require-extension srfi-1 srfi-13 srfi-14 regex)
+;; (use srfi-1 srfi-13 srfi-14 regex)
+;; (declare (export parse-cookie-string construct-cookie-string))
+
+;; #>
+;; #include
+;; <#
+;;
+;; (define fmt-time
+;; (foreign-lambda* c-string ((long secs_since_epoch))
+;; "static char buf[256];"
+;; "time_t t = (time_t) secs_since_epoch;"
+;; "strftime(buf, sizeof(buf), \"%a, %d-%b-%Y %H:%M:%S GMT\", gmtime(&t));"
+;; "return(buf);"))
+
+
+(define (fmt-time seconds)
+ (time->string (seconds->utc-time seconds) "%D"))
+
+ ;; utility fn. breaks ``attr=value;attr=value ... '' into alist.
+ ;; version is a cookie version. if version>0, we allow comma as the
+ ;; delimiter as well as semicolon.
+ (define (parse-av-pairs input version)
+ (define attr-regexp
+ (if (= version 0)
+ (regexp "\\s*([\\w$_-]+)\\s*([=\\;]\\s*)?")
+ (regexp "\\s*([\\w$_-]+)\\s*([=\\;,]\\s*)?")))
+ (define attr-delim
+ (if (= version 0) #\; (char-set #\, #\\ #\;)))
+
+ (define (read-attr input r)
+ (cond ((string-null? input) (reverse! r))
+ ((string-search attr-regexp input)
+ => (lambda (m)
+ (if (and-let* ((delimiter (third m))) ;;is an attr_value pai
+ (string-prefix? "=" delimiter))
+ (let ((attr (second m))
+ (rest (string-search-after attr-regexp input)))
+ (if (string-prefix? "\"" rest)
+ (read-token-quoted attr (string-drop rest 1) r)
+ (read-token attr rest r)))
+ (read-attr (string-search-after attr-regexp input) ;; Skip ahead if broken input?
+ (alist-cons (second m) #f r)))))
+ (else
+ ;; the input is broken; for now, we ignore the rest.
+ (reverse! r))))
+ (define (read-token attr input r)
+ (cond ((string-index input attr-delim)
+ => (lambda (i)
+ (read-attr (string-drop input (+ i 1))
+ (alist-cons attr
+ (string-trim-right (string-take input i))
+ r))))
+ (else
+ (reverse! (alist-cons attr (string-trim-right input) r)))))
+ (define (read-token-quoted attr input r)
+ (let loop ((input input)
+ (partial '()))
+ (cond ((string-index input (char-set #\\ #\"))
+ => (lambda (i)
+ (let ((c (string-ref input i)))
+ (if (char=? c #\\)
+ (if (< (string-length input) (+ i 1))
+ (error-unterminated attr)
+ (loop (string-drop input (+ i 2))
+ (cons* (string (string-ref input (+ i 1)))
+ (string-take input i)
+ partial)))
+ (read-attr (string-drop input (+ i 1))
+ (alist-cons attr
+ (string-concatenate-reverse
+ (cons (string-take input i)
+ partial))
+ r))))))
+ (else (error-unterminated attr)))))
+ (define (error-unterminated attr)
+ (error "Unterminated quoted value given for attribute" attr))
+
+ (read-attr input '()))
+
+ ;; Parses the header value of "Cookie" request header.
+ ;; If cookie version is known by "Cookie2" request header, it should
+ ;; be passed to version (as integer). Otherwise, it figures out
+ ;; the cookie version from input.
+ ;;
+ ;; Returns the following format.
+ ;; (( [:path ] [:domain ] [:port ])
+ ;; ...)
+
+ (define (parse-cookie-string input #!optional version)
+ (let ((ver (cond ((integer? version) version)
+ ((string-search "^\\s*\\$Version\\s*=\\s*(\\d+)" input)
+ => (lambda (m)
+ (string->number (cadr m))))
+ (else 0))))
+ (let loop ((av-pairs (parse-av-pairs input ver))
+ (r '())
+ (current '()))
+ (cond ((null? av-pairs)
+ (if (null? current)
+ (reverse r)
+ (reverse (cons (reverse current) r))))
+ ((string-ci=? "$path" (caar av-pairs))
+ (loop (cdr av-pairs) r (cons* (cdar av-pairs) path: current)))
+ ((string-ci=? "$domain" (caar av-pairs))
+ (loop (cdr av-pairs) r (cons* (cdar av-pairs) domain: current)))
+ ((string-ci=? "$port" (caar av-pairs))
+ (loop (cdr av-pairs) r (cons* (cdar av-pairs) port: current)))
+ (else
+ (if (null? current)
+ (loop (cdr av-pairs) r (list (cdar av-pairs) (caar av-pairs)))
+ (loop (cdr av-pairs)
+ (cons (reverse current) r)
+ (list (cdar av-pairs) (caar av-pairs)))))))))
+
+ ;; Construct a cookie string suitable for Set-Cookie or Set-Cookie2 header.
+ ;; specs is the following format.
+ ;;
+ ;; (( [:comment ] [:comment-url ]
+ ;; [:discard ] [:domain ]
+ ;; [:max-age ] [:path ] [:port ]
+ ;; [:secure ] [:version ] [:expires ]
+ ;; ) ...)
+ ;;
+ ;; Returns a list of cookie strings for each = pair. In the
+ ;; ``new cookie'' implementation, you can join them by comma and send it
+ ;; at once with Set-cookie2 header. For the old netscape protocol, you
+ ;; must send each of them by Set-cookie header.
+
+
+ (define (construct-cookie-string specs #!optional (version 1))
+ (map (lambda (spec) (construct-cookie-string-1 spec version))
+ specs))
+
+ (define (construct-cookie-string-1 spec ver)
+ (when (< (length spec) 2)
+ (error "bad cookie spec: at least and required" spec))
+ (let ((name (car spec))
+ (value (cadr spec)))
+ (let loop ((attr (cddr spec))
+ (r (list (if value
+ (string-append name "="
+ (quote-if-needed value))
+ name))))
+ (define (next s) (loop (cddr attr) (cons s r)))
+ (define (ignore) (loop (cddr attr) r))
+ (cond
+ ((null? attr) (string-join (reverse r) ";"))
+ ((null? (cdr attr))
+ (error (conc "bad cookie spec: attribute " (car attr) " requires value" )))
+ ((eqv? comment: (car attr))
+ (if (> ver 0)
+ (next (string-append "Comment=" (quote-if-needed (cadr attr))))
+ (ignore)))
+ ((eqv? comment-url: (car attr))
+ (if (> ver 0)
+ (next (string-append "CommentURL=" (quote-value (cadr attr))))
+ (ignore)))
+ ((eqv? discard: (car attr))
+ (if (and (> ver 0) (cadr attr)) (next "Discard") (ignore)))
+ ((eqv? domain: (car attr))
+ (next (string-append "Domain=" (cadr attr))))
+ ((eqv? max-age: (car attr))
+ (if (> ver 0)
+ (next (sprintf "Max-Age=~a" (cadr attr)))
+ (ignore)))
+ ((eqv? path: (car attr))
+ (next (string-append "Path=" (quote-if-needed (cadr attr)))))
+ ((eqv? port: (car attr))
+ (if (> ver 0)
+ (next (string-append "Port=" (quote-value (cadr attr))))
+ (ignore)))
+ ((eqv? secure: (car attr))
+ (if (cadr attr) (next "Secure") (ignore)))
+ ((eqv? version: (car attr))
+ (if (> ver 0)
+ (next (sprintf "Version=~a" (cadr attr)))
+ (ignore)))
+ ((eqv? expires: (car attr))
+ (if (> ver 0)
+ (ignore)
+ (next (make-expires-attr (cadr attr)))))
+ (else (error "Unknown cookie attribute" (car attr))))
+ ))
+ )
+
+
+ ;; (define (quote-value value)
+ ;; (string-append "\"" (regexp-replace-all #/\"|\\/ value "\\\\\\0") "\""))
+
+ (define (quote-value value)
+ (string-append "\"" (string-substitute* value '(("\\\"" . "\\\"") ("\\\\" . "\\\\"))) "\""))
+
+ (define quote-if-needed
+ (let ((rx (regexp "[\\\",;\\\\ \\t\\n]")))
+ (lambda (value)
+ (if (string-search rx value)
+ (quote-value value)
+ value))))
+
+ (define (make-expires-attr time)
+ (sprintf "Expires=~a"
+ (if (number? time)
+ (fmt-time time)
+ time)))
+
+ ;;;; Added support functions from my utils, split this out
+
+ (define (string-search-after r s #!optional (start 0))
+ (and-let* ((match-indices (string-search-positions r s start))
+ (right-match (second (first match-indices))))
+ (substring s right-match)))
+)
ADDED stml2/doc/Makefile
Index: stml2/doc/Makefile
==================================================================
--- /dev/null
+++ stml2/doc/Makefile
@@ -0,0 +1,7 @@
+all : manual.pdf web-page.html
+
+manual.pdf : manual.txt
+ a2x -a toc -f pdf manual.txt
+ # asciidoc -a toc plan.txt
+ a2x -f chunked -a toc manual.txt
+
ADDED stml2/doc/howto.txt
Index: stml2/doc/howto.txt
==================================================================
--- /dev/null
+++ stml2/doc/howto.txt
@@ -0,0 +1,177 @@
+Gotchas!
+=======
+
+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")
+
+(s:get-param 'param1) => "value1"
+(s:get-param 'param1 'number) => number or #f
+
+NOTE: it is often practical to use the generic (s:get-inp ...) which
+ will first look for the POST input variable and then fall back
+ to the GET param. This allows one to switch back and forth
+ between GET and POST during development without changing the code.
+
+(s:get-inp 'param1) ;; trys to find input by name of param1, followed by trying get-param
+
+Create a link.
+~~~~~~~~~~~~~~
+
+(s:a name 'href
+ (s:link-to "pagename/blah" ""))
+
+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
+
+
+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.
+
+
+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
+
+
+Get and set a session var
+~~~~~~~~~~~~~~~~~~~~~~~~~
+
+(s:session-var-get "keyname")
+(s:session-var-get "keyname" 'number)
+(s:session-var-set! "keyname" "value")
+
+5.1 Page local vars
+
+(s:set! key val)
+(s:get key)
+
+
+make a selection drop down
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+;; items is a hierarchial alist
+;; ( (label1 value1 dispval1 #t) ;; <== this one is selected
+;; (label2 (label3 value2 dispval2)
+;; (label4 value3 dispval3)))
+
+In view.scm:
+
+;; Label Value visible-str selected
+(s:select '(("World" 0)("Country" 1)("State" 2 "The state" #t )("Town/City" 3)) 'name 'scope)
+
+Visible str will be shown if provided. Selected will set that entry to pre-selected.
+
+To select a specific entry:
+
+(s:select '(("World" 0 "world" #f)("Country" 1 "country" #t)("State" 2 "state" #f)("Town/City" 3 "town" #f)) 'name 'scope)
+
+In control.scm:
+
+(let ((scope (s:get-input 'scope))
+ (scope-num (s:get-input 'scope 'number))) ;; 'number, 'raw or 'escaped
+ ....
+
+The optional fourth entry sets that item as selected if true
+
+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))))
+
+
+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)
+
+
+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")
+
+Radio buttons:
+
+ (s:div 'class "col_3"
+ (s:input 'type "radio" 'id "group-type1" 'name "group-type" 'value "private" 'checked "checked")
+ (s:label 'for "group-type1" 'class "inline" "Private")
+ (s:input 'type "radio" 'id "group-type2" 'name "group-type" 'value "public")
+ (s:label 'for "group-type2" 'class "inline" "Public"))
+
+ (s:get-input 'group-type) ==> returns private or public depending on which is selected.
ADDED stml2/doc/manual.txt
Index: stml2/doc/manual.txt
==================================================================
--- /dev/null
+++ stml2/doc/manual.txt
@@ -0,0 +1,56 @@
+STML User Manual
+================
+Matt Welland
+v1.0, 2012-6
+
+NOT DONE YET! :( sorry.
+
+:numbered!:
+[abstract]
+Example Abstract
+----------------
+
+Yada about stml
+
+:numbered:
+
+User Data Specification
+-----------------------
+
+.User Data
+[width="100%",options="header",cols="-- create table polls(id serial not null,poll_type text,title text,description text,poll_state text);
+-- create table poll_categories(id serial not null,poll_id integer,description text);
+-- create table poll_votes(id serial not null,period integer,poll_type text,poll_category text,voter_group integer, votes integer);
+
+-- create table vote_items (id serial primary key,type integer,item_id integer,item_level text,town_votes integer,state_votes integer,country_votes integer,world_votes integer);
+--
+-- alter table vote_items alter column town_votes set default 0;
+-- alter table vote_items alter column state_votes set default 0;
+-- alter table vote_items alter column country_votes set default 0;
+-- alter table vote_items alter column world_votes set default 0;
+--
+-- alter table poll_items add column class_0 int4;
+-- alter table poll_items add column class_1 int4;
+-- alter table poll_items add column class_2 int4;
+--
+-- alter table poll_items add column classp_0 int4;
+-- alter table poll_items add column classp_1 int4;
+-- alter table poll_items add column classp_2 int4;
+--
+-- alter table poll_items alter column classp_0 set default 0;
+-- alter table poll_items alter column classp_1 set default 0;
+-- alter table poll_items alter column classp_2 set default 0;
+--
+-- alter table poll_items add column suggestor int4;
+--
+-- alter table poll_items alter column class_0 set default 0;
+-- alter table poll_items alter column class_1 set default 0;
+-- alter table poll_items alter column class_2 set default 0;
+--
+-- alter table poll_items add column status int4;
+-- alter table poll_items alter column status set default 0;
+
+-- alter table poll_items add column url text;
+-- alter table vote_items add column submit_date date;
+-- alter table poll_items add column submit_date date;
+
+-- alter table people add column pt_balance int4;
+-- alter table people alter column pt_balance set default 0;
+
+-- alter table people add column cert_date date;
+-- alter table people alter column pt_balance set default 0;
+
+-- create table pt_transactions (id serial not null,from_id integer,to_id integer,amount integer,transaction_time timestamp);
+-- alter table pt_transactions alter column amount set default 0;
+
+-- alter table classifieds add column points int4;
+-- alter table classifieds alter column points set default 0;
+
+-- alter table pt_transactions add column comment text;
+-- alter table pt_transactions add column comment text;
+
+-- create table temp_key(id serial not null,key text,sent_date date);
+-- alter table people add column lastlogin timestamp;
+
+-- create table pictures(id serial not null,owner integer,size integer,name text,type text,md5sum text,uploaded date);
+-- alter table pictures add column status text;
+
+-- create table pic_allocation(id serial not null,picnum integer,used_by integer);
+
+-- alter table posts add column url text;
+-- alter table posts add column blurb text;
+
+insert into subjects (subjectid,subject,item_type,description) values('VoSp','Spanish','lang','Basic Spanish Vocabulary');
+insert into subjects (subjectid,subject,item_type,description) values('HoMe','Homeopathy','Info','Basic Homeopathy');
+
+alter table items add column group_name text;
+alter table items add column state int4;
+
+create table sessions (id serial not null,session_key text);
+create table session_vars (id serial not null,session_id integer,page text,key text,value text);
+
+alter table poll_items add column num_voted integer default 0;
+alter table poll_items add column vote_tot integer default 0;
+alter table poll_items add column item_votes integer default 0;
+
+-- remember ballots are used for many things other than polls!!!!!!!!
+create table ballots (id serial not null, item_id integer, class_id integer, votes integer, type_id integer);
+create table ballot_classes (id serial not null, name text, pts_per_vote integer); -- join with ballots to sum up votes (pts are really votes)
+insert into ballot_classes values (0,'',1);
+insert into ballot_classes values (1,'',2);
+insert into ballot_classes values (2,'',10);
+insert into ballot_classes values (3,'',20);
+insert into ballot_classes values (4,'',45);
+insert into ballot_classes values (5,'',90);
+insert into ballot_classes values (6,'',105);
+insert into ballot_classes values (7,'',145);
+insert into ballot_classes values (8,'',205);
+insert into ballot_classes values (9,'',245);
+
+create table ballot_types (id serial not null, name text); -- poll plurality = 0, poll approval = 1
+insert into ballot_types (id,name) values (0,'poll plurality');
+insert into ballot_types (id,name) values (1,'poll approval');
+
+alter table voted add column type_id integer;
+alter table voted add column id serial not null;
+create table voted_types (id serial not null, name text);
+insert into voted_types (id, name) values (0, 'poll vote'); -- YES!!! WE DO NEED voted_types SEPERATE FROM ballot_types
+insert into voted_types (id, name) values (1, 'council vote for poll'); -- yes, they are similar but I think combining them would be
+insert into voted_types (id, name) values (2, 'council vote for item'); -- painful.
+insert into voted_types (id, name) values (3, 'council vote for story');
+
+alter table people add column email_validated integer default 0; -- has email been validated? Hmmm... should this be a seperate table
+alter table people add column grade integer default 0; --
+
+alter table voted add column grade integer default 0;
+
+-- grade
+--
+-- 0 - no status (refusing cookies)
+-- 1 - has session
+-- 2 - logged in, has user id
+-- 3 - email validated
+-- 4 ++ add 1 for every 20 points of cert_level
+
+alter table poll_items drop column class_0 ;
+alter table poll_items drop column class_1 ;
+alter table poll_items drop column class_2 ;
+alter table poll_items drop column classp_0 ;
+alter table poll_items drop column classp_1 ;
+alter table poll_items drop column classp_2 ;
+alter table poll_items drop column votes ;
+alter table poll_items drop column vote_tot ;
+alter table poll_items drop column num_voted;
+
+alter table poll_items add column a_vote_tot integer default 0; -- approval votes total
+alter table poll_items add column p_vote_tot integer default 0; -- plurality votes total
+
+alter table people alter column num set default 0;
+alter table polls add column discussion_id integer default 0;
+
+create table poll_status (id serial not null, name text);
+insert into poll_status (id,name) values (0, 'In queue'); -- just posted and in queue
+insert into poll_status (id,name) values (1, 'Posted'); -- published to discussion
+
+-- fix default cert_level
+alter table people alter column cert_level set default 0;
+update people set cert_level=0 where cert_level is NULL;
+
+create table discussions (id serial not null,type_id integer,activity_state integer);
+update posts set thread=id where parent=0; -- was this necessary?
+
+insert into discussions select id,0,1 from posts where parent=0;
+
+-- ======================================================================
+-- New council stuff
+--======================================================================
+
+create table councils (id serial not null, name text, discussion_id integer default 0);
+alter table council_members add column join_date date;
+
+-- DONE ON TANG UP TO HERE
+
+--======================================================================
+-- New locations table
+--======================================================================
+
+create table locations
+ (id serial not null, parent_id integer default 0,
+ council_id integer,nick text, fullname text,
+ level_id integer, blurb text, pict_id integer);
+insert into locations(council_id,nick,fullname,level_id,blurb)
+ values(0,'','World',0,'Our beloved Planet Earth');
+insert into locations(council_id,nick,fullname,level_id,blurb)
+ values(1,'us','United States',1,'The Land of the Free');
+insert into locations(parent_id,council_id,nick,fullname,level_id,blurb)
+ values(1,2,'az','Arizona',2,'It''s a dry heat');
+
+drop table location;
+drop table towns;
+drop table states;
+drop table neighborhoods ;
+drop table countries;
ADDED stml2/example/db/dump_db
Index: stml2/example/db/dump_db
==================================================================
--- /dev/null
+++ stml2/example/db/dump_db
@@ -0,0 +1,1 @@
+pg_dump -d kiatoa | grep -v 'INSERT INTO session_vars' | grep -v 'INSERT INTO sessions' > Kiatoa.sql
ADDED stml2/example/docs/Setup-notes.txt
Index: stml2/example/docs/Setup-notes.txt
==================================================================
--- /dev/null
+++ stml2/example/docs/Setup-notes.txt
@@ -0,0 +1,15 @@
+1) add:
+
+host all all 192.168.1.1/32 password
+
+to the bottom of /etc/postgresql/8.2/main/pg_hba.conf
+
+2)
+
+ln -s /home/matt/kiatoa/kiatoa-scm/kiatoa /var/www
+
+3) copy/update the stml.conf file
+
+sudo cp stml.conf.template /usr/lib/cgi-bin/.stml.conf
+sudo vi /usr/lib/cgi-bin/.stml.conf
+
ADDED stml2/example/docs/comments.txt
Index: stml2/example/docs/comments.txt
==================================================================
--- /dev/null
+++ stml2/example/docs/comments.txt
@@ -0,0 +1,20 @@
+
+If we had any at all of the alternative voting ideas like instant runoff, Condorcet, any of them, I think it might make the whole process better
+
+My thought was to get people familiar with approval voting, then get people to pledge only to vote for a candidate if that candidate supported approval voting. I put the beginings of a site together here: http://approvalvote.org but stopped working on it because I decided not to push the idea for this election. Morally, in my opinion, letting the neocons in for another term is unacceptable, I suspect (but don't know) that McCain is a participant of the neocon movement. Since these elections can hinge on a few hundreds of votes I thought it wasn't worth even the infintesimal risk of any activity that would get people thinking about the alternatives to the top two pulling votes away from Obama. I did think of pushing the idea in venues dominated by interest in Ron Paul but there was some beer in the fridge and, well, you can guess the rest of that story.
+
+Although the current implementation needs major rework I do think the idea has potential.
+
+ 1. Get people to experience plurality vs approval voting. IMHO once you've tried it going back to plurality is actually quite uncomfortable.
+ 2. Get people to pledge to vote only for candidates that support approval voting.
+ 3. Get candidates to address approval voting.
+
+Now why approval and not Condorcet, range, IRV or any one of the dozens of other voting techniques?
+
+ 1. Approval is 100% doable using existing election machines
+ 2. Approval is highly resistant to any meaningful strategic voting.
+ 3. Approval is easy for the end users. Go try doing some condorcet or IRV ranked voting. It is really tedious.
+ 4. IRV is *worse* than Plurality in its vunerablity to strategic voting.
+ 5. Condorcet is too hard to grok for most folks. I knew once how it worked but couldn't explain it to someone right now for the life of me.
+
+In short the marginal improvement of the more complex voting solutions over approval doesn't buy much.
ADDED stml2/example/example/layout.css
Index: stml2/example/example/layout.css
==================================================================
--- /dev/null
+++ stml2/example/example/layout.css
@@ -0,0 +1,244 @@
+
+/*-General-----------------------------------------------*/
+
+html, body {
+ margin:0px;
+ padding:0px;
+}
+
+form {
+ display:inline;
+ margin:0px;
+ padding:0px;
+}
+
+a img {
+ border:none;
+ margin:0px;
+ padding:0px;
+}
+
+h1, h2, h3, h4, h5, h6, p, div {
+ margin:0px;
+ padding:0px;
+}
+
+.right {
+ float:right;
+}
+
+.left{
+ float:left;
+}
+
+/*-Main Layout-------------------------------------------*/
+
+#overall {
+ margin:5px 12px 0px 12px;
+ padding:0px;
+}
+
+/*-Header-------------*/
+
+.header {
+ position:relative;
+ height:90px;
+}
+
+/*-Footer-------------*/
+
+.footer {
+ padding:40px 0px 0px 0px;
+ position:relative;
+ clear:both;
+}
+
+/*-Content Area-------*/
+
+.content {
+ width:100%;
+}
+
+/*-Left Column--------*/
+
+.leftcolumn {
+ float:left;
+ width:145px;
+ margin:5px;
+}
+
+.leftcolumn .node {
+ margin:0px 0px 15px 0px;
+}
+
+.leftcolumn .node h1 {
+ padding:0px 0px 0px 3px;
+}
+
+.leftcolumn .node ul {
+ margin:0px;
+ padding:0px;
+}
+
+.leftcolumn .node li {
+ display:block;
+ padding:0px 0px 0px 3px;
+ margin:0px;
+}
+
+.leftcolumn .node li.more{
+ padding:0px 0px 0px 6px;
+}
+
+/*-Center Column------*/
+
+.centercolumn {
+ margin: 5px;
+ margin-left:152px;
+ margin-right:200px;
+ font-family:"\"}\"";
+ font-family:inherit;
+}
+
+.centercolumn .node h1 {
+ padding: 0px 0px 0px 13px;
+}
+
+.centercolumn .node h4 {
+ margin: 15px 0px 10px 0px;
+}
+
+.centercolumn .node p {
+ margin: 0px 0px 10px 0px; */
+ padding: 0px 0px 0px 0px;
+} /* this seemed not to work */
+
+.posts_0 {
+ margin: 0px 0px 0px 0px;
+}
+
+.posts_1 {
+ margin: 0px 0px 0px 20px;
+}
+
+.posts_2 {
+ margin: 0px 0px 0px 40px;
+}
+
+.posts_3 {
+ margin: 0px 0px 0px 60px;
+}
+
+.posts_4 {
+ margin: 0px 0px 0px 80px;
+}
+
+.posts_5 {
+ margin: 0px 0px 0px 100px;
+}
+
+.posts_6 {
+ margin: 0px 0px 0px 120px;
+}
+
+.posts_7 {
+ margin: 0px 0px 0px 140px;
+}
+
+.posts_8 {
+ margin: 0px 0px 0px 160px;
+}
+
+.posts_9 {
+ margin: 0px 0px 0px 160px;
+}
+
+.posts_10 {
+ margin: 0px 0px 0px 180px;
+}
+
+/*-Right Column-------*/
+
+.rightcolumn {
+ float:right;
+ width:190px;
+ margin:5px 5px 0px 0px;
+}
+
+* html .rightcolumn {
+ margin:3px 3px 3px 3px;
+}
+
+body>div .rightcolumn {
+ margin:0px 0px 0px 0px;
+}
+
+.rightcolumn .node {
+ margin:0px 0px 5px 0px;
+ padding:0px;
+}
+
+.rightcolumn .node h2 {
+ margin:3px 3px 3px 2px;
+}
+
+.rightcolumn .node ul {
+ list-style-position:inside;
+ margin:0px;
+ padding:1px;
+}
+
+.rightcolumn .node ul.none {
+ list-style-position:inside;
+}
+
+.rightcolumn .node ul.dot {
+ list-style-position:inside;
+}
+
+.rightcolumn .node ul.books {
+ list-style-position:outside;
+ margin:0px 0px 0px 35px;
+}
+
+.rightcolumn .node li {
+ padding:0px 0px 0px 3px;
+ margin:0px;
+}
+
+/*-Remaining layout--------------------------------------*/
+
+#title {
+ top: 0px;
+ left: 0px;
+ position: absolute;
+}
+
+#search {
+ float:left;
+ margin:0px 0px 0px 30px;
+}
+
+#randomquote {
+ float:right;
+ margin:0px 30px 0px 0px;
+}
+
+#copyright {
+ text-align:center;
+ padding:15px 0px 0px 0px;
+ margin:0px 0px 0px 0px;
+ clear:both;
+}
+
+#bottomNav {
+ text-align:center;
+ margin:0px 0px 20px 0px;
+ padding:0px;
+}
+
+#oldStuffNav {
+ font-weight:bold;
+ text-align:right;
+}
+
ADDED stml2/example/example/markup.css
Index: stml2/example/example/markup.css
==================================================================
--- /dev/null
+++ stml2/example/example/markup.css
@@ -0,0 +1,299 @@
+/*-General-----------------------------------------------*/
+
+body {
+ background-color:#ffffff;
+ color:#0f0f0f;
+ font-family:serif;
+ font-weight:normal;
+ text-decoration:none;
+/* font-size:x-small; */
+ voice-family:"\"}\"";
+ voice-family:inherit;
+ font-size:small;
+}
+
+html>body {
+ font-size:small;
+}
+
+.strong {
+ font-weight:bold;
+}
+
+#red {
+ color: #ff0000
+}
+
+/*-Main Markup-------------------------------------------*/
+
+#overall {
+ background-color: #ffffff;
+ color:#000000;
+}
+
+/*-Left Column--------*/
+
+.leftcolumn .node a {
+ color:#006666;
+ background-color:transparent;
+}
+
+.leftcolumn .node p {
+ font-size:1.2em;
+ font-weight:normal;
+}
+
+.leftcolumn .node h1 {
+ font-weight:normal;
+ font-size:1.2em;
+ color:#ffffff;
+ background-color:#000000; /* #005991; #7f9bff #006666; */
+}
+
+.leftcolumn .node h1 a {
+ color:#ffffff;
+ background-color:transparent;
+}
+
+.leftcolumn .node h2 {
+ font-weight:bold;
+ font-size:.95em;
+}
+
+.leftcolumn .node ul {
+ list-style-type:none;
+}
+
+.leftcolumn .node li.more {
+ font-weight:bold;
+ font-size:.75em;
+}
+
+.leftcolumn .node li.selected {
+ font-weight:bold;
+ font-size:1.18em;
+ color:#000000;
+ background-color:#cccccc;
+}
+
+.leftcolumn .node li.selected a {
+ color:#000000;
+ background-color:transparent;
+}
+
+/*-Center Column for classifieds-*/
+
+.centercolumn .classifieds h1 {
+ font-family:Arial, Helvetica, serif;
+ font-weight:bold;
+ font-size:1.38em;
+ color:#000000; /* ffffff; */
+ background: #5390b7; /* a6bcac; #0c1e0f; 043b0d; 1a6126; */
+}
+
+/*-Center Column------*/
+.centercolumn .node {
+ font-family:serif;
+}
+
+.centercolumn .node a {
+ color:#006666;
+ background-color:transparent;
+}
+
+.centercolumn .node h1 {
+ font-family:Arial, Helvetica, serif;
+ font-weight:bold;
+ font-size:1.38em;
+ color:#ffffff;
+ background:#000000; /* #005991; */
+} /* #006666 /* url('../images/slc.gif') no-repeat; */
+
+.centercolumn .node h1 a {
+ color:#ffffff;
+ background-color:transparent;
+}
+
+.centercolumn .node h2 {
+ font-weight:bold;
+ font-size:1.18em;
+}
+
+.centercolumn .node h3 {
+ font-weight:bold;
+ font-size:.95em;
+}
+
+.centercolumn .node h4 {
+ font-weight:normal;
+ font-size:1.2em;
+}
+
+.centercolumn .node h4 a {
+ font-weight:bold;
+}
+
+.centercolumn .node p {
+ font-weight:normal;
+}
+
+.centercolumn .posts_0 h1 {
+ color:#ffffff;
+ background-color:#606060;
+ font-size:1.18em;
+}
+
+.centercolumn .posts_1 h1 {
+ color:#ffffff;
+ background-color:#606060;
+ font-size:1.18em;
+}
+
+.centercolumn .posts_2 h1 {
+ color:#ffffff;
+ background-color:#606060;
+ font-size:1.18em;
+}
+
+.centercolumn .posts_3 h1 {
+ color:#ffffff;
+ background-color:#606060;
+ font-size:1.18em;
+}
+
+.centercolumn .posts_4 h1 {
+ color:#ffffff;
+ background-color:#606060;
+ font-size:1.18em;
+}
+
+.centercolumn .posts_5 h1 {
+ color:#ffffff;
+ background-color:#606060;
+ font-size:1.18em;
+}
+
+.centercolumn .posts_6 h1 {
+ color:#ffffff;
+ background-color:#606060;
+ font-size:1.18em;
+}
+
+.centercolumn .posts_7 h1 {
+ color:#ffffff;
+ background-color:#606060;
+ font-size:1.18em;
+}
+
+.centercolumn .posts_8 h1 {
+ color:#ffffff;
+ background-color:#606060;
+ font-size:1.18em;
+}
+
+.centercolumn .posts_9 h1 {
+ color:#ffffff;
+ background-color:#606060;
+ font-size:1.18em;
+}
+
+.centercolumn .posts_10 h1 {
+ color:#ffffff;
+ background-color:#606060;
+ font-size:1.18em;
+}
+
+/*-Right Column-------*/
+
+.rightcolumn .node {
+ color:#000000;
+ background-color:#cccccc;
+ font-family:serif;
+}
+
+.rightcolumn .node a {
+ color:#000000; /* #005991; #006666; */
+ background-color:transparent;
+}
+
+.rightcolumn .node h1 {
+ font-family:Arial, Helvetica, serif;
+ font-weight:bold;
+ font-size:0.95em; /* 1.38em; */
+ color:#ffffff;
+ background-color: #000000; /* #005991; #006666; */
+}
+
+.rightcolumn .node h1 a {
+ color:#ffffff;
+ background-color:transparent;
+}
+
+.rightcolumn .node h2 {
+ font-weight:bold;
+ font-size:.95em;
+}
+
+.rightcolumn .node ul.none {
+ list-style-type:none;
+}
+
+.rightcolumn .node ul.dot {
+ list-style-type:none;
+ /* list-style-image:url('../images/listdot.gif'); */
+}
+
+.rightcolumn .node ul.books {
+ list-style-type:disc;
+}
+
+/*-OSDN Navagation bar-----------------------------------*/
+
+#OSDNNavbar {
+ background-color:#999999;
+ color:#000000; /* #005991; /* #006666; */
+}
+
+#OSDNNavbar div#links {
+ background-color:#999999;
+ color:#000000; /* #005991; /* #006666; */
+}
+
+#OSDNNavbar a {
+ background-color: transparent;
+ color: #000000; /* #005991; /* #006666; */
+}
+
+/*-Remaining layout--------------------------------------*/
+
+#randomquote {
+ font-size:1.2em;
+ font-style:italic;
+}
+
+#copyright {
+ font-size:.75em;
+ font-family:Arial, Helvetica, serif;
+ background-color:transparent;
+ color:#000000; /* #005991; /* #006666; */
+}
+
+#copyright a {
+ background-color:transparent;
+ color:#000000; /* #005991; /* #006666; */
+}
+
+#bottomNav {
+ background-color:transparent;
+ color:#000000; /* #005991; /* #006666; */
+}
+
+#bottomNav a {
+ background-color:transparent;
+ color:#ffffff;
+}
+
+#oldStuffNav {
+ font-weight:bold;
+}
+
ADDED stml2/example/models/candidate.scm
Index: stml2/example/models/candidate.scm
==================================================================
--- /dev/null
+++ stml2/example/models/candidate.scm
@@ -0,0 +1,67 @@
+;; Copyright 2007-2008, Matthew Welland. matt@kiatoa.com All rights reserved.
+;;
+;; models/candidates.scm
+;;
+
+(define (candidate:get-top n)
+ (dbi:get-rows
+ (s:db)
+ "SELECT DISTINCT id,name,url,party,desc,supports_av,date_added,score,pscore FROM candidates AS c ORDER BY score DESC LIMIT ?;" n))
+
+;; HERE !!!! getting vote counts... DONT'USE- SEE VOTED INSTEAD
+(define (candidate:get-votes candidates vote_type)
+ (let ((ids (map (lambda (c)(candidate:get-id c)) candidates)))
+ (dbi:get-rows (s:db)
+ (conc
+ "SELECT id,sum(votes*(1+score)) WHERE vote_date>"
+ (- (current-time) (* 24 60 60 7)) ;; seven days
+ " AND id IN "
+ (apply conc (intersperse ids ","))))))
+
+(define (candidate:get-by-name name)
+ (dbi:get-one-row (s:db) "SELECT id,name,url,party,desc,supports_av,date_added,score,pscore FROM candidates WHERE name=?;" name))
+
+;; update an existing candidate or create if new
+(define (candidate:update dat)
+ (let* ((name (candidate:get-name dat))
+ (olddat (candidate:get-by-name name)))
+ (if olddat
+ (begin
+ (dbi:exec (s:db)
+ "UPDATE candidates SET url=?,party=?,desc=?,supports_av=? WHERE name=?;"
+ (candidate:get-url dat)
+ (candidate:get-party dat)
+ (candidate:get-desc dat)
+ (candidate:get-supports-av dat)
+ name)
+ (candidate:get-by-name name))
+ (begin
+ (dbi:exec (s:db)
+ "INSERT INTO candidates (name,url,party,desc,supports_av) VALUES(?,?,?,?,?);"
+ name
+ (candidate:get-url dat)
+ (candidate:get-party dat)
+ (candidate:get-desc dat)
+ (candidate:get-supports-av dat))
+ (candidate:get-by-name name)))))
+
+
+(define (candidate:get-id dat)(vector-ref dat 0))
+(define (candidate:get-name dat)(vector-ref dat 1))
+(define (candidate:get-url dat)(vector-ref dat 2))
+(define (candidate:get-party dat)(vector-ref dat 3))
+(define (candidate:get-desc dat)(vector-ref dat 4))
+(define (candidate:get-supports-av dat)(vector-ref dat 5))
+(define (candidate:get-date-added dat)(vector-ref dat 6))
+(define (candidate:get-score dat)(vector-ref dat 7))
+(define (candidate:get-pscore dat)(vector-ref dat 8))
+
+(define (candidate:set-id! dat val)(vector-set! dat 0 val))
+(define (candidate:set-name! dat val)(vector-set! dat 1 val))
+(define (candidate:set-url! dat val)(vector-set! dat 2 val))
+(define (candidate:set-party! dat val)(vector-set! dat 3 val))
+(define (candidate:set-desc! dat val)(vector-set! dat 4 val))
+(define (candidate:set-supports-av! dat val)(vector-set! dat 5 val))
+(define (candidate:set-date-added! dat val)(vector-set! dat 6 val))
+(define (candidate:set-score! dat val)(vector-set! dat 7 val))
+
ADDED stml2/example/models/maint.scm
Index: stml2/example/models/maint.scm
==================================================================
--- /dev/null
+++ stml2/example/models/maint.scm
@@ -0,0 +1,57 @@
+;; Copyright 2007-2008, Matthew Welland. matt@kiatoa.com All rights reserved.
+;;
+;; maint/control.scm
+;;
+
+;; evolve your schema here!
+;; Add entries and then go to http:/your-url/maint
+;;
+;; first make maint:db available as a global
+;;
+(define maint:db (slot-ref s:session 'conn))
+
+;; you can store lambda's or SQL queries to be exectuted
+;; be extremely careful - especially with the lambda's!!!
+(define maint:schema-updates
+ (list (list 1 (lambda ()(keystore:set! maint:db "MAINTPW" "Abc123")))
+ (list 2 "CREATE TABLE people (id INTEGER PRIMARY KEY,name TEXT DEFAULT '',nick TEXT DEFAULT '',email TEXT,password TEXT,status INTEGER DEFAULT 0,score INTEGER DEFAULT 0,location_id INTEGER DEFAULT 0);")
+ (list 3 "CREATE TABLE candidates (id INTEGER PRIMARY KEY,name TEXT DEFAULT '',url TEXT DEFAULT '',party TEXT DEFAULT '',desc TEXT DEFAULT '',supports_av INTEGER,date_added DATETIME,score INTEGER DEFAULT 0);")
+ (list 4 "CREATE TABLE votes (id INTEGER PRIMARY KEY,candidate_id INTEGER,vote_date INTEGER,votes INTEGER,score INTEGER,vote_type INTEGER);")
+ (list 5 "CREATE TABLE voted (id INTEGER PRIMARY KEY,user_id INTEGER,vote_date INTEGER,score INTEGER);")
+ ;; location_type can be: city, town, state, region, county etc
+ (list 6 "CREATE TABLE locations (id INTEGER PRIMARY KEY,parent_id INTEGER,codename TEXT,name TEXT,location_type TEXT,desc TEXT,url TEXT);")
+ (list 7 "INSERT INTO locations VALUES(0,0,'ea','earth','planet','Home Planet of Humans','');")
+ (list 8 "ALTER TABLE candidates ADD column pscore INTEGER DEFAULT 0;")
+ ))
+
+(define (maint:am-i-maint?)
+ ;; Enter a maint password - return #t if good
+ #t)
+
+(define (maint:update-tables)
+ (let* ((db (slot-ref s:session 'conn))
+ (curr-ver (s:any->number (keystore:get db "SCHEMA-VERSION"))))
+ (if (not curr-ver)
+ (begin
+ (keystore:set! (slot-ref s:session 'conn) "SCHEMA-VERSION" 0)
+ (set! curr-ver 0)))
+ (if (null? maint:schema-updates)
+ (keystore:set! (slot-ref s:session 'conn) "SCHEMA-VERSION" 0)
+ (let loop ((hed (car maint:schema-updates))
+ (tal (cdr maint:schema-updates))
+ (highest-ver 0))
+ (if (< (length hed) 2)
+ (s:log "Malformed maint:schema-updates table in maint/control.scm")
+ (let ((ver (car hed))
+ (act (cadr hed)))
+ (if (> ver curr-ver) ;; need to apply this one
+ (begin
+ (if (string? act)
+ (dbi:exec db act)
+ (act))
+ ;; yes, do this for each one, just in case of a crash
+ (keystore:set! db "SCHEMA-VERSION" ver)))
+ (if (null? tal)
+ highest-ver
+ (loop (car tal)(cdr tal) ver))))))))
+
ADDED stml2/example/models/person.scm
Index: stml2/example/models/person.scm
==================================================================
--- /dev/null
+++ stml2/example/models/person.scm
@@ -0,0 +1,68 @@
+;; Copyright 2007-2008, Matthew Welland. matt@kiatoa.com All rights reserved.
+;;
+;; models/person.scm
+;;
+(require "md5")
+
+(define (person:get-dat email)
+ (dbi:get-one-row (s:db) "SELECT id,name,email,status,password,score FROM people WHERE email=?;" email))
+
+;; this effectively auto logs in using "" as the password
+(define (person:create-or-get email)
+ (let ((dat (person:get-dat email)))
+ (if dat
+ (person:authenticate email "")
+ (person:set-password email ""))))
+
+(define (person:password-match? password cryptedpw)
+ (string=? (md5:digest password) cryptedpw))
+
+(define (person:authenticate email password)
+ (let ((pdat (person:get-dat email)))
+ (if pdat
+ ;; (if (s:password-match? password (vector-ref pdat 4))
+ (if (person:password-match? password (vector-ref pdat 4))
+ pdat ;; password matched, return basic record id,name,email,status
+ #f)
+ #f)))
+
+;; sets password, creates user if doesn't exist
+(define (person:set-password email password)
+ (let ((pdat (person:get-dat email))
+ ;; (cpwd (s:crypt-passwd password #f)))
+ (cpwd (md5:digest password)))
+ (if pdat
+ (dbi:exec (s:db)
+ "UPDATE people SET password=? WHERE email=?;"
+ cpwd
+ email)
+ (dbi:exec (s:db)
+ "INSERT INTO people (name,email,password) VALUES(?,?,?);"
+ ""
+ email
+ cpwd))
+ (if pdat
+ pdat
+ (person:get-dat email))))
+
+(define (person:learn_enabled? email)
+ (eq? (dbi:get-one (s:db) "SELECT status FROM people WHERE email=?;" email)
+ 1))
+
+(define(person:files_enabled? email)
+ #f)
+
+;; id,name,email,status,password,score
+(define (person:get-id dat)(vector-ref dat 0))
+(define (person:get-name dat)(vector-ref dat 1))
+(define (person:get-email dat)(vector-ref dat 2))
+(define (person:get-status dat)(vector-ref dat 3))
+(define (person:get-password dat)(vector-ref dat 4))
+(define (person:get-score dat)(vector-ref dat 5))
+
+(define (person:set-id! dat val)(vector-set! dat 0 val))
+(define (person:set-name! dat val)(vector-set! dat 1 val))
+(define (person:set-email! dat val)(vector-set! dat 2 val))
+(define (person:set-status! dat val)(vector-set! dat 3 val))
+(define (person:set-password! dat val)(vector-set! dat 4 val))
+(define (person:set-score! dat val)(vector-set! dat 5 val))
ADDED stml2/example/models/voting.scm
Index: stml2/example/models/voting.scm
==================================================================
--- /dev/null
+++ stml2/example/models/voting.scm
@@ -0,0 +1,61 @@
+;; Copyright 2007-2008, Matthew Welland. matt@kiatoa.com All rights reserved.
+;;
+;; models/voting.scm
+;;
+;; store the votes!
+
+;; look up the entry to which to add
+(define (voting:get-entry-id candidate-id score type)
+ (dbi:get-one (s:db) "SELECT id FROM votes WHERE candidate_id=? AND score=? AND vote_type=? AND vote_date>?;"
+ candidate-id
+ score
+ type
+ (- (current-seconds) 86400))) ;; i.e. since 24 hrs ago
+
+(define (voting:apply-vote dat candidate-id vote-type)
+ (let* ((score (person:get-score dat))
+ (vote-entry-id (voting:get-entry-id candidate-id score vote-type)))
+ (if vote-entry-id
+ (dbi:exec (s:db) "UPDATE votes SET votes=votes+1 WHERE id=?;" vote-entry-id)
+ (dbi:exec (s:db) "INSERT INTO votes (candidate_id,vote_date,votes,score,vote_type) VALUES(?,?,?,?,?);"
+ candidate-id
+ (current-seconds)
+ 1
+ score
+ vote-type))))
+
+(define (voting:rollup-votes)
+ (let ((adat (dbi:get-rows (s:db)
+ "SELECT candidate_id AS id,SUM(votes*(score+1)) AS score FROM votes WHERE vote_date>? AND vote_type=1 GROUP BY candidate_id;"
+ (- (current-seconds) (* 24 60 60 7))))
+ (pdat (dbi:get-rows (s:db)
+ "SELECT candidate_id AS id,SUM(votes*(score+1)) AS score FROM votes WHERE vote_date>? AND vote_type=0 GROUP BY candidate_id;"
+ (- (current-seconds) (* 24 60 60 7)))))
+ (for-each
+ (lambda (row)
+ (dbi:exec (s:db) "UPDATE candidates SET score=? WHERE id=?;" (vector-ref row 1)(vector-ref row 0)))
+ adat)
+ (for-each
+ (lambda (row)
+ (dbi:exec (s:db) "UPDATE candidates SET pscore=? WHERE id=?;" (vector-ref row 1)(vector-ref row 0)))
+ pdat)))
+
+;; vote_type: 0=plurality, 1=approval
+(define (voting:handle-votes email approval plurality)
+ (let* ((pdat (let ((e (s:session-var-get "email")))
+ (if e
+ (person:get-dat e)
+ (person:create-or-get (if (or (not (string? email))
+ (string-match (regexp "^\\s*$") email))
+ "noname"
+ email)))))) ;; is this really the logic I wanted?
+ ;; (s:log "Got here eh!" " pdat: " pdat)
+ (if (not pdat)
+ (s:set! "errmsg" "Failed to auto log in/register, email or nick already in use. Consider reseting your password")
+ (begin
+ (s:session-var-set! "email" (person:get-email pdat))
+ (voting:apply-vote pdat plurality 0)
+ (map (lambda (candidate-id)
+ (voting:apply-vote pdat candidate-id 1))
+ approval)
+ (voting:rollup-votes)))))
ADDED stml2/example/pages/action/view.scm
Index: stml2/example/pages/action/view.scm
==================================================================
--- /dev/null
+++ stml2/example/pages/action/view.scm
@@ -0,0 +1,51 @@
+;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
+;;
+(s:div 'class "node"
+ (s:h1 "Approval voting works")
+ "
Approval voting is very resistant to strategic voting and it is
+ extremely easy to implement using existing ballot technology.
+
Every four years voters must
+ make a painful strategic choice, either vote for the candidate
+ they really want and risk getting saddled
+ with a candidate they don't want, OR
+ vote for the most palatable frontrunner, and send a false
+ message of disinterest in their true choice."
+ (s:h1 "Thinking is required for a democracy to work")
+ "
Consider trying the "fool test" on an unsuspecting friend or aquaintence.
+ . Pick a popular smear or other known distortion aimed at a candidate you suspect your
+ "person under test", or PUT,
+ doesn't like. Research the item and find out the truth about it as
+ best you can. Start with
+ factcheck.org but don't stop there. Use google or other search
+ engines to build up a picture of what is true.
+
+
Once you are armed with information you can apply the test. Ask your
+ friend or collegue for the truth behind the smear. Be neutral. Accept
+ their answer without judgement if it is incorrect. Say "oh", or
+ "thanks" and let it be at that. Again, DO NOT CORRECT THEM!
+
+
If your PUT fails the test don't harp on them or correct them.
+ Although everyone is responsible for researching the facts many people will
+ lock onto their existing ideas if challenged. Instead say something like,
+ "you may want to research that" and accept that you are dealing with
+ someone who just might be a fool, unwilling or unable to look at their
+ favorite candidate with a critical eye.
+
Finally, be prepared to be tested yourself,
+ aggressively research the smears your favored candidates put out. If they are true
+ be prepared to prove it, if they are false, be prepared to put them in
+ context or simply admit they are false. No candidate will be perfect."
+ (s:h1 "A strategy for change")
+ "
Get a yes/no answer from your favored candidate about approval voting.
+ If your candidate refuses to support approval voting first hear them out. If their
+ reasons are good then publish them so we can all learn from it. If their
+ reasons are weak then look for an alternative candidate to support.
+
+
Improve your score here on approvalvote.org and then vote again in our front
+ page poll. Your score will adjust the power of your vote such that the poll
+ will reflect the choices of those who are willing to think.
+
+ We will advocate that everyone votes for an approval vote supporting independant
+ candidate if that candidate is at least 10% ahead of the next candidate of
+ the same leaning (i.e. liberal or conservative). Otherwise you should vote
+ for the frontrunner candidate of your choosen leaning due to the dangers of
+ plurality voting.")
ADDED stml2/example/pages/footer/view.scm
Index: stml2/example/pages/footer/view.scm
==================================================================
--- /dev/null
+++ stml2/example/pages/footer/view.scm
@@ -0,0 +1,5 @@
+;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
+;;
+;; footer
+(list
+ (s:div 'class "node" "This is the footer"))
ADDED stml2/example/pages/header/control.scm
Index: stml2/example/pages/header/control.scm
==================================================================
--- /dev/null
+++ stml2/example/pages/header/control.scm
@@ -0,0 +1,9 @@
+;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
+;;
+;; header/control.scm
+
+;; (load (s:model-path "blah"))
+(define header:menu-items '(("home" "Home")("learn" "Learn")("action" "Take Action")("discussion" "Discussion")
+ ("preferences" "Preferences")))
+(define header:title (let ((t (s:get-param 'section)))
+ (if t t "Home")))
ADDED stml2/example/pages/header/view.scm
Index: stml2/example/pages/header/view.scm
==================================================================
--- /dev/null
+++ stml2/example/pages/header/view.scm
@@ -0,0 +1,30 @@
+;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
+;;
+;; header/view.scm
+;;
+(list
+ ;; (s:div 'id "titlebar"
+ (s:table
+ (s:tr
+ (s:td (s:img 'src "/www/images/approvalvote.png"
+ 'alt "ApprovalVote.com"
+ 'title "Welcome to ApprovalVote.com"))
+ (s:td 'valign "top" 'align "right"
+ (s:table 'border "0" 'cellspacing "0"
+ (s:tr
+ (s:td 'valign "center" ;; 'width "250" ;; 'rowspan "2"
+ (s:a (s:small " * NOW IS A GREAT TIME TO PUSH FOR APPROVAL VOTING! * "))
+ (s:br)))
+ (s:tr
+ (s:td 'columnspan="3"
+ (s:center "*********")))))) ;; header:title))))))
+ ;; this is the horizontal menus
+ (s:tr 'columnspan "4"
+ (s:table
+ (s:tr
+ (map (lambda (m-item)
+ (s:td (s:small "["
+ (s:a 'href (s:link-to (car m-item))(cadr m-item))
+ "]")))
+ header:menu-items)
+ )))));; )
ADDED stml2/example/pages/home/view.scm
Index: stml2/example/pages/home/view.scm
==================================================================
--- /dev/null
+++ stml2/example/pages/home/view.scm
@@ -0,0 +1,12 @@
+;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
+;;
+(s:div 'class "node"
+ (s:h1 "Please Help Save Our Democracy.")
+ "
We need approval voting to re-energize our democracy.
+ Our system is in danger of failing us since it leaves us powerless
+ to force change. Arguably the biggest problem lies in our use of
+ plurality voting to choose leaders.
+ ")
+(s:div 'class "node"
+ (s:h1 "Practice some approval voting now!")
+ (s:call "uspresident"))
ADDED stml2/example/pages/index/control.scm
Index: stml2/example/pages/index/control.scm
==================================================================
--- /dev/null
+++ stml2/example/pages/index/control.scm
@@ -0,0 +1,6 @@
+;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
+;;
+;; this gets read for ALL pages. Don't weigh it down excessively!
+;;
+;; index/control.scm
+
ADDED stml2/example/pages/index/view.scm
Index: stml2/example/pages/index/view.scm
==================================================================
--- /dev/null
+++ stml2/example/pages/index/view.scm
@@ -0,0 +1,21 @@
+;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
+;;
+;; index
+
+(list
+ (s:html
+ (s:head
+ (s:title "Approval Voting Now!")
+ (s:link 'rel "stylesheet" 'type "text/css" 'href "/approvalvote/markup.css")
+ (s:link 'rel "stylesheet" 'type "text/css" 'href "/approvalvote/layout.css"))
+ (s:body
+ (s:div 'class "header" (s:call "header"))
+ (s:div 'class "rightcolumn" (s:call "rightcol"))
+ (s:div 'class "leftcolumn" (s:call "leftnav"))
+ (s:div 'class "centercolumn"
+ (let ((page (slot-ref s:session 'page)))
+ (if page
+ (s:call page)
+ (list (s:h2 "Home")
+ (s:call "sys-state")))))
+ (s:div 'class "footer" (s:call "footer")))))
ADDED stml2/example/pages/learn/view.scm
Index: stml2/example/pages/learn/view.scm
==================================================================
--- /dev/null
+++ stml2/example/pages/learn/view.scm
@@ -0,0 +1,7 @@
+;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
+;;
+(s:div 'class "node"
+ (s:h1 "Resources")
+ "
Two excellent sites with more information on approval voting:
+