;"db2html.scm" Convert relational database to hyperlinked pages.
; Copyright 1997, 1998, 2000, 2001 Aubrey Jaffer
;
;Permission to copy this software, to modify it, to redistribute it,
;to distribute modified versions, and to use it for any purpose is
;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
(require 'uri)
(require 'printf)
(require 'html-form)
(require 'directory)
(require 'databases)
(require 'string-case)
(require 'string-search)
(require 'common-list-functions)
(require-if 'compiling 'pretty-print)
(require-if 'compiling 'database-commands)
(require 'hash)
(define (crc:hash-obj obj) (number->string (hash obj most-positive-fixnum) 16))
;;@code{(require 'db->html)}
;;@ftindex db->html
;;@body
(define (html:table options . rows)
(apply string-append
(sprintf #f "
\\n" (or options ""))
(append rows (list (sprintf #f "
\\n")))))
;;@args caption align
;;@args caption
;;@2 can be @samp{top} or @samp{bottom}.
(define (html:caption caption . align)
(if (null? align)
(sprintf #f " %s\\n"
(html:plain caption))
(sprintf #f " %s\\n"
(car align)
(html:plain caption))))
;;@body Outputs a heading row for the currently-started table.
(define (html:heading columns)
(sprintf #f " \\n%s\\n"
(apply string-append
(map (lambda (datum)
(sprintf #f " %s\\n" (or datum "")))
columns))))
;;@body Outputs a heading row with column-names @1 linked to URIs @2.
(define (html:href-heading columns uris)
(html:heading
(map (lambda (column uri)
(if uri
(html:link uri column)
column))
columns uris)))
(define (row->anchor pkl row)
(sprintf #f "" (uri:make-path (butnthcdr pkl row))))
;;@args k foreigns
;;
;;The positive integer @1 is the primary-key-limit (number of
;;primary-keys) of the table. @2 is a list of the filenames of
;;foreign-key field pages and #f for non foreign-key fields.
;;
;;@0 returns a procedure taking a row for its single argument. This
;;returned procedure returns the html string for that table row.
(define (html:linked-row-converter pkl foreigns)
(define idxs (do ((idx (length foreigns) (+ -1 idx))
(nats '() (cons idx nats)))
((not (positive? idx)) nats)))
(require 'pretty-print)
(lambda (row)
(define (present datum)
(if (or (string? datum) (symbol? datum))
(html:plain datum)
(let* ((str (pretty-print->string datum))
(len (+ -1 (string-length str))))
(cond ((eqv? (string-index str #\newline) len)
(string-append "" (substring str 0 len) ""))
(else (html:pre str))))))
(sprintf #f " |
\\n%s\\n"
(apply string-append
(map (lambda (idx datum foreign)
(sprintf
#f " %s%s\\n"
(if (eqv? 1 idx) (row->anchor pkl row) "")
(cond ((or (not datum) (null? datum)) "")
((not foreign) (present datum))
((equal? "catalog-data.html" foreign)
(html:link (make-uri
(table-name->filename datum)
#f #f)
(present datum)))
(else (html:link (make-uri foreign #f datum)
(present datum))))))
idxs row foreigns)))))
;;@body
;;Returns the symbol @1 converted to a filename.
(define (table-name->filename table-name)
(and table-name (string-append
(string-subst (symbol->string table-name) "*" "" ":" "_")
".html")))
(define (table-name->column-table-name db table-name)
((((db 'open-table) '*catalog-data* #f) 'get 'coltab-name)
table-name))
;;@args caption db table-name match-key1 @dots{}
;;Returns HTML string for @2 table @3 chopped into 50-row HTML tables.
;;Every foreign-key value is linked to the page (of the table)
;;defining that key.
;;
;;The optional @4 @dots{} arguments restrict actions to a subset of
;;the table. @xref{Table Operations, match-key}.
(define (table->linked-html caption db table-name . args)
(let* ((table ((db 'open-table) table-name #f))
(foreigns (table 'column-foreigns))
(tags (map table-name->filename foreigns))
(names (table 'column-names))
(primlim (table 'primary-limit)))
(define tables '())
(define rows '())
(define cnt 0)
(define (make-table rows)
(apply html:table "CELLSPACING=0 BORDER=1"
(html:caption caption 'BOTTOM)
(html:href-heading
names
(append (make-list primlim
(table-name->filename
(table-name->column-table-name db table-name)))
(make-list (- (length names) primlim) #f)))
(html:heading (table 'column-domains))
(html:href-heading foreigns tags)
(html:heading (table 'column-types))
rows))
(apply (table 'for-each-row)
(lambda (row)
(set! cnt (+ 1 cnt))
(set! rows (cons row rows))
(cond ((<= 50 cnt)
(set! tables
(cons (make-table
(map (html:linked-row-converter primlim tags)
(reverse rows)))
tables))
(set! cnt 0)
(set! rows '()))))
args)
(apply string-append
(reverse (if (and (null? rows) (not (null? tables)))
tables
(cons (make-table
(map (html:linked-row-converter primlim tags)
(reverse rows)))
tables))))))
;;@body
;;Returns a complete HTML page. The string @3 names the page which
;;refers to this one.
;;
;;The optional @4 @dots{} arguments restrict actions to a subset of
;;the table. @xref{Table Operations, match-key}.
(define (table->linked-page db table-name index-filename . args)
(string-append
(if index-filename
(html:head table-name
(html:link (make-uri index-filename #f table-name)
(html:plain table-name)))
(html:head table-name))
(html:body (apply table->linked-html table-name db table-name args))))
(define (html:catalog-row-converter row foreigns)
(sprintf #f " |
\\n%s\\n"
(apply string-append
(map (lambda (datum foreign)
(sprintf #f " %s%s\\n"
(html:anchor (sprintf #f "%s" datum))
(html:link (make-uri foreign #f #f) datum)))
row foreigns))))
;;@body
;;Returns HTML string for the catalog table of @1.
(define (catalog->html db caption . args)
(apply html:table "BORDER=1"
(html:caption caption 'BOTTOM)
(html:heading '(table columns))
(map (lambda (row)
(cond ((and (eq? '*columns* (caddr row))
(not (eq? '*columns* (car row))))
"")
(else (html:catalog-row-converter
(list (car row) (caddr row))
(list (table-name->filename (car row))
(table-name->filename (caddr row)))))))
(apply (((db 'open-table) '*catalog-data* #f) 'row:retrieve*)
args))))
;;Returns complete HTML page (string) for the catalog table of @1.
(define (catalog->page db caption . args)
(string-append (html:head caption)
(html:body (apply catalog->html db caption args))))
;;@subsection HTML editing tables
;;@noindent A client can modify one row of an editable table at a time.
;;For any change submitted, these routines check if that row has been
;;modified during the time the user has been editing the form. If so,
;;an error page results.
;;
;;@noindent The behavior of edited rows is:
;;
;;@itemize @bullet
;;@item
;;If no fields are changed, then no change is made to the table.
;;@item
;;If the primary keys equal null-keys (parameter defaults), and no other
;;user has modified that row, then that row is deleted.
;;@item
;;If only primary keys are changed, there are non-key fields, and no
;;row with the new keys is in the table, then the old row is
;;deleted and one with the new keys is inserted.
;;@item
;;If only non-key fields are changed, and that row has not been
;;modified by another user, then the row is changed to reflect the
;;fields.
;;@item
;;If both keys and non-key fields are changed, and no row with the
;;new keys is in the table, then a row is created with the new
;;keys and fields.
;;@item
;;If fields are changed, all fields are primary keys, and no row with
;;the new keys is in the table, then a row is created with the new
;;keys.
;;@end itemize
;;
;;@noindent After any change to the table, a @code{sync-database} of the
;;database is performed.
;;@args table-name null-keys update delete retrieve
;;@args table-name null-keys update delete
;;@args table-name null-keys update
;;@args table-name null-keys
;;
;;Returns procedure (of @var{db}) which returns procedure to modify
;;row of @1. @2 is the list of @dfn{null} keys indicating the row is
;;to be deleted when any matches its corresponding primary key.
;;Optional arguments @3, @4, and @5 default to the @code{row:update},
;;@code{row:delete}, and @code{row:retrieve} of @1 in @var{db}.
(define (command:modify-table table-name null-keys . args)
(define argc (length args))
(lambda (rdb)
(define table ((rdb 'open-table) table-name #t))
(let ((table:update (or (and (> argc 0) (car args)) (table 'row:update)))
(table:delete (or (and (> argc 1) (cadr args)) (table 'row:delete)))
(table:retrieve (or (and (> argc 2) (caddr args)) (table 'row:retrieve)))
(pkl (length null-keys)))
(define ptypes (butnthcdr pkl (table 'column-types)))
(if (> argc 4) (slib:error 'command:modify-table 'too-many-args
table-name null-keys args))
(lambda (*keys* *row-hash* . new-row)
(let* ((new-pkeys (butnthcdr pkl new-row))
(pkeys (uri:path->keys (uri:split-fields *keys* #\/) ptypes))
(row (apply table:retrieve pkeys))
(same-nonkeys? (equal? (nthcdr pkl new-row) (nthcdr pkl row))))
(cond ((equal? pkeys new-pkeys) ;did not change keys
(cond ((not row) '("Row deleted by other user"))
((equal? (crc:hash-obj row) *row-hash*)
(table:update new-row)
((rdb 'sync-database)) #t)
(else '("Row changed by other user"))))
((command:null-key? null-keys new-pkeys) ;blanked keys
(cond ((not row) #t)
((equal? (crc:hash-obj row) *row-hash*)
;;(slib:warn (sprintf #f "Removing key: %#a => %#a" new-pkeys ))
(apply table:delete pkeys)
((rdb 'sync-database)) #t)
(else '("Row changed by other user"))))
(else ;changed keys
(set! row (apply table:retrieve new-pkeys))
(cond (row (list "Row already exists"
(sprintf #f "%#a" row)))
(else (table:update new-row)
(if (and same-nonkeys?
(not (null? (nthcdr pkl new-row))))
(apply table:delete pkeys))
((rdb 'sync-database)) #t)))))))))
(define (command:null-key? null-keys new-pkeys)
(define sts #f)
(for-each (lambda (nuk nep) (if (equal? nuk nep) (set! sts #t)))
null-keys
new-pkeys)
sts)
(define (make-defaulter arity type)
`(lambda (pl)
',(case arity
((optional nary) '())
((boolean) #f)
((single nary1)
(case type
((string) '(""))
((symbol) '(nil))
((number) '(0))
(else '(#f))))
(else (slib:error 'make-defaulter 'unknown 'arity arity)))))
;;@body Given @2 in @1, creates parameter and @code{*command*} tables
;;for editing one row of @2 at a time. @0 returns a procedure taking a
;;row argument which returns the HTML string for editing that row.
;;
;;Optional @3 are expressions (lists) added to the call to
;;@code{command:modify-table}.
;;
;;The domain name of a column determines the expected arity of the data
;;stored in that column. Domain names ending in:
;;
;;@table @samp
;;@item *
;;have arity @samp{nary};
;;@item +
;;have arity @samp{nary1}.
;;@end table
(define (command:make-editable-table rdb table-name . args)
(define table ((rdb 'open-table) table-name #t))
(require 'database-commands)
(let ((pkl (table 'primary-limit))
(columns (table 'column-names))
(domains (table 'column-domains))
(types (table 'column-types))
(idxs (do ((idx (length (table 'column-names)) (+ -1 idx))
(nats '() (cons (+ 2 idx) nats)))
((not (positive? idx)) nats)))
(ftn (((rdb 'open-table) '*domains-data* #f) 'get 'foreign-table)))
(define field-specs
(map (lambda (idx column domain type)
(let* ((dstr (symbol->string domain))
(len (+ -1 (string-length dstr))))
(define arity
(case (string-ref dstr len)
((#\*) 'nary)
((#\+) 'nary1)
(else (if (eq? 'boolean type) 'boolean 'single))))
(case (string-ref dstr len)
((#\* #\+)
(set! type (string->symbol (substring dstr 0 len)))
(set! domain type)))
`(,idx ,column ,arity ,domain
,(make-defaulter arity type) #f "")))
idxs columns domains types))
(define foreign-choice-lists
(map (lambda (domain-name)
(define tab-name (ftn domain-name))
(if tab-name (get-foreign-choices
((rdb 'open-table) tab-name #f)) '()))
domains))
(define-tables rdb
`(,(symbol-append table-name '- 'params)
*parameter-columns* *parameter-columns*
((1 *keys* single string #f #f "")
(2 *row-hash* single string #f #f "")
,@field-specs))
`(,(symbol-append table-name '- 'pname)
((name string))
((parameter-index ordinal)) ;should be address-params
(("*keys*" 1)
("*row-hash*" 2)
,@(map (lambda (idx column) (list (symbol->string column) idx))
idxs columns)))
`(*commands*
desc:*commands* desc:*commands*
((,(symbol-append 'edit '- table-name)
,(symbol-append table-name '- 'params)
,(symbol-append table-name '- 'pname)
(command:modify-table ',table-name
',(map (lambda (fs)
(define dfl
((slib:eval (car (cddddr fs)))
'()))
(if (pair? dfl) (car dfl) dfl))
(butnthcdr pkl field-specs))
,@args)
,(string-append "Modify " (symbol->string table-name))))))
(let ((arities (map caddr field-specs)))
(lambda (row)
(define elements
(map form:element
columns
arities
(map (lambda (fld arity) (case arity
((nary nary1) fld)
(else (list fld))))
row arities)
foreign-choice-lists))
(sprintf #f " |
\\n %s%s\\n\\n"
(string-append
(html:hidden '*row-hash* (crc:hash-obj row))
(html:hidden '*keys* (uri:make-path (butnthcdr pkl row)))
;; (html:hidden '*suggest* '<>)
(car elements)
(form:submit '<> (symbol-append 'edit '- table-name))
;; (form:image "Modify Row" "/icons/bang.png")
)
(apply string-append
(map (lambda (elt) (sprintf #f " | %s\\n" elt))
(cdr elements))))))))
;;@args k names edit-point edit-converter
;;
;;The positive integer @1 is the primary-key-limit (number of
;;primary-keys) of the table. @2 is a list of the field-names. @3 is
;;the list of primary-keys denoting the row to edit (or #f). @4 is the
;;procedure called with @1, @2, and the row to edit.
;;
;;@0 returns a procedure taking a row for its single argument. This
;;returned procedure returns the html string for that table row.
;;
;;Each HTML table constructed using @0 has first @1 fields (typically
;;the primary key fields) of each row linked to a text encoding of these
;;fields (the result of calling @code{row->anchor}). The page so
;;referenced typically allows the user to edit fields of that row.
(define (html:editable-row-converter pkl names edit-point edit-converter)
(require 'pretty-print)
(let ((idxs (do ((idx (length names) (+ -1 idx))
(nats '() (cons idx nats)))
((not (positive? idx)) nats)))
(datum->html
(lambda (datum)
(if (or (string? datum) (symbol? datum))
(html:plain datum)
(let* ((str (pretty-print->string datum))
(len (+ -1 (string-length str))))
(cond ((eqv? (string-index str #\newline) len)
(string-append "" (substring str 0 len) ""))
(else (html:pre str))))))))
(lambda (row)
(string-append
(sprintf #f " |
\\n%s\\n"
(apply string-append
(map (lambda (idx datum foreign)
(sprintf
#f " %s%s\\n"
(if (eqv? 1 idx) (row->anchor pkl row) "")
(cond ((or (not datum) (null? datum)) "")
((<= idx pkl)
(let ((keystr (uri:make-path
(butnthcdr pkl row))))
(sprintf #f "%s"
keystr keystr
(datum->html datum))))
(else (datum->html datum)))))
idxs row names)))
(if (and edit-point edit-converter
(equal? (butnthcdr pkl edit-point) (butnthcdr pkl row)))
(edit-converter row)
"")))))
;;@subsection HTML databases
;;@body @1 must be a relational database. @2 must be #f or a
;;non-empty string naming an existing sub-directory of the current
;;directory.
;;
;;@0 creates an html page for each table in the database @1 in the
;;sub-directory named @2, or the current directory if @2 is #f. The
;;top level page with the catalog of tables (captioned @4) is written
;;to a file named @3.
(define (db->html-files db dir index-filename caption)
(set! dir (if dir (sub-vicinity "" dir) ""))
(call-with-output-file (in-vicinity dir index-filename)
(lambda (port)
(display (catalog->page db caption) port)))
(let ((catdat ((db 'open-table) '*catalog-data* #f)))
((or (catdat 'for-each-row-in-order) (catdat 'for-each-row))
(lambda (row)
(call-with-output-file
(in-vicinity dir (table-name->filename (car row)))
(lambda (port)
(display (table->linked-page db (car row) index-filename) port)))))))
;;@args db dir index-filename
;;@args db dir
;;@1 must be a relational database. @2 must be a non-empty
;;string naming an existing sub-directory of the current directory or
;;one to be created. The optional string @3 names the filename of the
;;top page, which defaults to @file{index.html}.
;;
;;@0 creates sub-directory @2 if neccessary, and calls
;;@code{(db->html-files @1 @2 @3 @2)}. The @samp{file:} URI of @3 is
;;returned.
(define (db->html-directory db dir . index-filename)
(set! index-filename (if (null? index-filename)
"index.html"
(car index-filename)))
(if (symbol? dir) (set! dir (symbol->string dir)))
(if (not (file-exists? dir)) (make-directory dir))
(db->html-files db dir index-filename dir)
(path->uri (in-vicinity (sub-vicinity (user-vicinity) dir) index-filename)))
;;@args db dir index-filename
;;@args db dir
;;@0 is just like @code{db->html-directory}, but calls
;;@code{browse-url} with the uri for the top page after the
;;pages are created.
(define (db->netscape . args)
(browse-url (apply db->html-directory args)))
|