;"db2html.scm" Convert relational database to hyperlinked pages.
; Copyright 1997, 1998, 2000 Aubrey Jaffer
;
;Permission to copy this software, to redistribute it, 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 warrantee 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 'html-form)
(require 'net-clients)

;;@code{(require 'db->html)}

;;@body
(define (html:table caption . rows)
  (apply string-append
	 (sprintf #f "<TABLE BORDER>\\n") ; WIDTH=\"100%%\"
	 (if caption
	     (sprintf #f "<CAPTION ALIGN=BOTTOM>%s</CAPTION>\\n"
		      (html:plain caption))
	     "")
	 (append rows (list (sprintf #f "</TABLE>\\n")))))

;;@body Outputs a heading row for the currently-started table.
(define (html:heading columns)
  (apply string-append
	 (sprintf #f "<TR VALIGN=\"TOP\">\\n")
	 (map (lambda (datum) (sprintf #f "<TH>%s\\n" (or datum "")))
	      columns)))

;;@body Outputs a heading row with column-names @1 linked to URLs @2.
(define (html:href-heading columns urls)
  (html:heading
   (map (lambda (column url)
	  (if url
	      (sprintf #f "<A HREF=\"%s\">%s</A>" url column)
	      column))
	columns urls)))

;;@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:row-converter pkl foreigns)
  (lambda (data-row)
    (define anchored? #f)
    (define (present datum)
      (cond ((or (string? datum) (symbol? datum))
	     (html:plain datum))
	    (else
	     (sprintf #f "<PRE>\\n%s</PRE>\\n"
		      (html:plain (call-with-output-string
				   (lambda (port)
				     (pretty-print datum port))))))))
    (apply string-append
	   "<TR VALIGN=\"TOP\">"
	   (append
	    (map (lambda (datum foreign)
		   (string-append
		    "<TD>"
		    (cond ((not datum) "")
			  ((null? datum) "")
			  ((not anchored?)
			   (set! anchored? (not (zero? pkl)))
			   (string-append
			    "<A NAME=\""
			    (cond ((zero? pkl) (html:atval datum))
				  (else (apply string-append
					       (html:atval (car data-row))
					       (map (lambda (datum)
						      (string-append
						       " " (html:atval datum)))
						    (cdr data-row)))))
			    "\">"))
			  (else ""))
		    (cond ((not datum) "")
			  ((null? datum) "")
			  ((not foreign) (present datum))
			  ((zero? pkl)
			   (sprintf #f "<A HREF=\"%s\">%s</A>"
				    foreign (present datum)))
			  (else
			   (sprintf #f "<A HREF=\"%s#%s\">%s</A>"
				    foreign
				    (html:atval datum)
				    (present datum))))))
		 data-row foreigns)
	    (list (sprintf #f "\\n"))))))

;;@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.
;;
;;The optional @4 @dots{} arguments restrict actions to a subset of
;;the table.  @xref{Table Operations, match-key}.
(define (table->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)))
    (apply html:table caption
	   (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))
	   (map (html:row-converter primlim tags)
		(apply (table 'row:retrieve*) args)))))

;;@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->page db table-name index-filename . args)
  (string-append
   (if index-filename
       (html:head table-name
		  (sprintf #f "<A HREF=\"%s#%s\">%s</A>"
			   index-filename
			   (html:atval table-name)
			   (html:plain table-name)))
       (html:head table-name))
   (html:body (apply table->html table-name db table-name args))))

;;@body
;;Returns HTML string for the catalog table of @1.
(define	(catalog->html db caption . args)
  (apply html:table caption
	 (html:heading '(table columns))
	 (map (lambda (row)
		(cond ((and (eq? '*columns* (caddr row))
			    (not (eq? '*columns* (car row))))
		       "")
		      (else ((html:row-converter
			      0 (list (table-name->filename (car row))
				      (table-name->filename (caddr row))))
			     (list (car row) (caddr row))))))
	      (apply (((db 'open-table) '*catalog-data* #f) 'row:retrieve*)
		     args))))

;;@body
;;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 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->files db dir index-filename caption)
  (call-with-output-file (in-vicinity (if dir (sub-vicinity "" dir) "")
				      index-filename)
    (lambda (port)
      (display (catalog->page db caption) port)))
  ((((db 'open-table) '*catalog-data* #f) 'for-each-row)
   (lambda (row)
     (call-with-output-file 
	 (in-vicinity (sub-vicinity "" dir) (table-name->filename (car row)))
       (lambda (port)
	 (display (table->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->files @1 @2 @3 @2)}.  The @samp{file:} URL of @3 is
;;returned.
(define (db->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->files db dir index-filename dir)
  (path->url (in-vicinity (sub-vicinity "" dir) index-filename)))

;;@args db dir index-filename
;;@args db dir
;;@0 is just like @code{db->directory}, but calls
;;@code{browse-url-netscape} with the url for the top page after the
;;pages are created.
(define (db->netscape . args)
  (browse-url-netscape (apply db->directory args)))
