From: Chris Hanson Date: Mon, 1 Nov 2004 19:22:29 +0000 (+0000) Subject: Create new xdoc directory. X-Git-Tag: 20090517-FFI~1486 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=b1e6a3b00b467900417d0e4b2e9fc8bd51b1cee7;p=mit-scheme.git Create new xdoc directory. --- diff --git a/v7/src/Makefile.in b/v7/src/Makefile.in index 6722966f8..559572612 100644 --- a/v7/src/Makefile.in +++ b/v7/src/Makefile.in @@ -1,4 +1,4 @@ -# $Id: Makefile.in,v 1.24 2004/10/29 05:32:18 cph Exp $ +# $Id: Makefile.in,v 1.25 2004/11/01 19:21:21 cph Exp $ # # Copyright 2000,2001,2002,2004 Massachusetts Institute of Technology # @@ -59,7 +59,8 @@ mkinstalldirs = $(SHELL) $(top_srcdir)/mkinstalldirs # **** END BOILERPLATE **** SUBDIRS = 6001 compiler rcs runtime-check sf win32 $(INSTALLED_SUBDIRS) -INSTALLED_SUBDIRS = microcode runtime cref edwin imail sos ssp star-parser xml +INSTALLED_SUBDIRS = microcode runtime cref edwin imail sos ssp star-parser \ + xdoc xml AUXDIR = @AUXDIR@ EDETC = $(AUXDIR)/edwin/etc diff --git a/v7/src/configure.ac b/v7/src/configure.ac index 0d2df0d19..60a6d891a 100644 --- a/v7/src/configure.ac +++ b/v7/src/configure.ac @@ -1,7 +1,7 @@ dnl Process this file with autoconf to produce a configure script. AC_INIT([MIT/GNU Scheme], [7.7.91], [bug-mit-scheme@gnu.org], [mit-scheme]) -AC_REVISION([$Id: configure.ac,v 1.1 2004/10/29 05:32:18 cph Exp $]) +AC_REVISION([$Id: configure.ac,v 1.2 2004/11/01 19:21:21 cph Exp $]) AC_CONFIG_SRCDIR([microcode/boot.c]) AC_PROG_MAKE_SET @@ -46,6 +46,7 @@ runtime/Makefile sos/Makefile ssp/Makefile star-parser/Makefile +xdoc/Makefile xml/Makefile ]) AC_OUTPUT diff --git a/v7/src/etc/optiondb.scm b/v7/src/etc/optiondb.scm index 02355b04a..05540f92e 100644 --- a/v7/src/etc/optiondb.scm +++ b/v7/src/etc/optiondb.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: optiondb.scm,v 1.12 2004/01/16 21:05:12 cph Exp $ +$Id: optiondb.scm,v 1.13 2004/11/01 19:22:29 cph Exp $ Copyright 2000,2001,2002,2004 Massachusetts Institute of Technology @@ -110,6 +110,9 @@ USA. (define-load-option 'WIN32 (guarded-system-loader '(win32) "win32")) +(define-load-option 'XDOC + (guarded-system-loader '(runtime ssp xdoc) "xdoc")) + (define-load-option 'XML (guarded-system-loader '(runtime xml) "xml")) diff --git a/v7/src/xdoc/Makefile.in b/v7/src/xdoc/Makefile.in new file mode 100644 index 000000000..4c9f66fea --- /dev/null +++ b/v7/src/xdoc/Makefile.in @@ -0,0 +1,73 @@ +# $Id: Makefile.in,v 1.1 2004/11/01 19:21:04 cph Exp $ +# +# Copyright 2004 Massachusetts Institute of Technology +# +# This file is part of MIT/GNU Scheme. +# +# MIT/GNU Scheme 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. +# +# MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +# 02111-1307, USA. + +# **** BEGIN BOILERPLATE **** + +SHELL = @SHELL@ + +@SET_MAKE@ + +srcdir = @srcdir@ +top_srcdir = @top_srcdir@ +VPATH = @srcdir@ +prefix = @prefix@ +exec_prefix = @exec_prefix@ + +bindir = @bindir@ +sbindir = @sbindir@ +libexecdir = @libexecdir@ +datadir = @datadir@ +sysconfdir = @sysconfdir@ +sharedstatedir = @sharedstatedir@ +localstatedir = @localstatedir@ +libdir = @libdir@ +infodir = @infodir@ +mandir = @mandir@ +includedir = @includedir@ +oldincludedir = /usr/include + +DESTDIR = +top_builddir = . + +INSTALL = @INSTALL@ +INSTALL_PROGRAM = @INSTALL_PROGRAM@ +INSTALL_DATA = @INSTALL_DATA@ +INSTALL_SCRIPT = @INSTALL_SCRIPT@ + +LN_S = @LN_S@ +ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 +mkinstalldirs = $(SHELL) $(top_srcdir)/mkinstalldirs + +# **** END BOILERPLATE **** + +AUXDIR = @AUXDIR@ +XDOC_DIR = $(AUXDIR)/xdoc + +include ../Makefile.std + +install: + $(mkinstalldirs) $(DESTDIR)$(XDOC_DIR) + $(INSTALL_DATA) *.com $(DESTDIR)$(XDOC_DIR)/. + $(INSTALL_DATA) *.bci $(DESTDIR)$(XDOC_DIR)/. + $(INSTALL_DATA) xdoc-unx.pkd $(DESTDIR)$(XDOC_DIR)/. + $(INSTALL_DATA) $(srcdir)/load.scm $(DESTDIR)$(XDOC_DIR)/. + +.PHONY: install diff --git a/v7/src/xdoc/compile.scm b/v7/src/xdoc/compile.scm new file mode 100644 index 000000000..5248dc76d --- /dev/null +++ b/v7/src/xdoc/compile.scm @@ -0,0 +1,34 @@ +#| -*-Scheme-*- + +$Id: compile.scm,v 1.1 2004/11/01 19:21:05 cph Exp $ + +Copyright 2004 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +USA. + +|# + +;;;; XDOC compilation + +(load-option 'CREF) +(with-working-directory-pathname (directory-pathname (current-load-pathname)) + (lambda () + (for-each compile-file + '("db" + "xdoc")) + (cref/generate-constructors "xdoc"))) \ No newline at end of file diff --git a/v7/src/xdoc/db.scm b/v7/src/xdoc/db.scm new file mode 100644 index 000000000..61665dbcd --- /dev/null +++ b/v7/src/xdoc/db.scm @@ -0,0 +1,739 @@ +#| -*-Scheme-*- + +$Id: db.scm,v 1.1 2004/11/01 19:21:05 cph Exp $ + +Copyright 2003,2004 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +USA. + +|# + +;;;; 6.002ex database support + +(declare (usual-integrations)) + +(define default-db-name "six002x_spring04") +(define pgsql-conn #f) +(define *database-connection* #f) +(define *user-name*) +(define *ps-number*) +(define *page-pathname*) +(define *page-key*) + +(define (with-database-connection ps-number pathname thunk) + (if (not (and pgsql-conn (pgsql-conn-open? pgsql-conn))) + (set! pgsql-conn (open-pgsql-conn (get-db-open-args pathname)))) + (let ((page-key (enough-namestring pathname (server-root-dir)))) + (if *database-connection* + (begin + (set! *database-connection* pgsql-conn) + (fluid-let ((*ps-number* ps-number) + (*page-pathname* pathname) + (*page-key* page-key)) + (thunk))) + (fluid-let ((*database-connection* pgsql-conn) + (*user-name* (http-request-user-name)) + (*ps-number* ps-number) + (*page-pathname* pathname) + (*page-key* page-key)) + (database-transaction thunk))))) + +(define (database-connection) + (let ((conn *database-connection*)) + (if (pgsql-conn-open? conn) + conn + (let ((conn (open-pgsql-conn (get-db-open-args *page-pathname*)))) + (set! pgsql-conn conn) + (set! *database-connection* conn) + conn)))) + +(define (get-db-open-args pathname) + (string-append "dbname=" (get-db-name pathname))) + +(define (get-db-name pathname) + (let loop ((directory (directory-pathname pathname))) + (let ((pathname (merge-pathnames ".xdoc-db" directory))) + (if (file-exists? pathname) + (call-with-input-file pathname read-line) + (let ((path (pathname-directory directory))) + (if (pair? (cdr path)) + (loop + (pathname-new-directory directory (except-last-pair path))) + default-db-name)))))) + +(define (database-transaction thunk) + (let ((commit? #f)) + (dynamic-wind (lambda () + (db-run-cmd "BEGIN")) + (lambda () + (let ((v (thunk))) + (set! commit? #t) + v)) + (lambda () + (db-run-cmd (if commit? "COMMIT" "ROLLBACK")))))) + +(define (close-database) + (if pgsql-conn + (begin + (if (pgsql-conn-open? pgsql-conn) + (close-pgsql-conn pgsql-conn)) + (set! pgsql-conn #f) + unspecific))) + +(define (db-run-query . strings) + (let ((query (string-append (apply string-append strings) ";"))) + (if debug-queries? + (write-line `(DB-RUN-QUERY ,query))) + (exec-pgsql-query (database-connection) query))) + +(define debug-queries? #f) + +(define (db-run-cmd . strings) + (let ((result (apply db-run-query strings))) + (let ((status (pgsql-cmd-status result))) + (pgsql-clear result) + status))) + +(define (db-quote object) + (if object + (if (exact-integer? object) + (number->string object) + (string-append "'" + (escape-pgsql-string + (if (symbol? object) + (symbol-name object) + object)) + "'")) + "NULL")) + +;;;; Problem-set registration + +(define (db-register-problem-set ps-number directory) + (db-run-cmd "DELETE FROM saved_inputs" + " WHERE ps_number = " (db-quote ps-number)) + (db-run-cmd "DELETE FROM saved_outputs" + " WHERE ps_number = " (db-quote ps-number)) + (db-run-cmd "DELETE FROM registered_outputs" + " WHERE ps_number = " (db-quote ps-number)) + (let ((n-parts 0) + (n-outputs 0)) + (for-each (lambda (pathname) + (if (not (string=? (pathname-name pathname) "index")) + (begin + (set! n-parts (+ n-parts 1)) + (set! n-outputs + (+ n-outputs + (register-part-outputs ps-number + pathname))))) + unspecific) + (directory-read (merge-pathnames "*.xdoc" directory))) + (values n-parts n-outputs))) + +(define (register-part-outputs ps-number pathname) + (with-xdoc-expansion-context ps-number pathname + (lambda (document) + (db-run-cmd "DELETE FROM persistent_values" + " WHERE file_name = " (db-quote *page-key*)) + (let ((root (xml-document-root document))) + (let ((ps-number* (int0-attribute 'problem-set root #t))) + (if (not (= ps-number* ps-number)) + (error "Document has wrong problem-set number:" + (file-namestring pathname)))) + (let ((part (xdoc-db-id root)) + (n-outputs 0)) + (let loop ((elt root)) + (for-each + (lambda (item) + (if (xml-element? item) + (begin + (if (xdoc-output? item) + (begin + (set! n-outputs (+ n-outputs 1)) + (register-output + ps-number + (xdoc-db-id item) + part + (eq? (or (boolean-attribute 'graded item #f) 'true) + 'true)))) + (loop item)))) + (xml-element-contents elt))) + n-outputs))))) + +(define (register-output ps-number name part graded?) + (db-run-cmd "INSERT INTO registered_outputs VALUES" + " (" (db-quote ps-number) + ", " (db-quote name) + ", " (db-quote part) + ", " (if graded? "TRUE" "FALSE") + ")")) + +(define (db-registered-problem-sets) + (let ((result + (db-run-query "SELECT DISTINCT ps_number" + " FROM registered_outputs" + " ORDER BY ps_number"))) + (let ((n (pgsql-n-tuples result))) + (do ((i 0 (+ i 1)) + (numbers '() + (cons (string->number (pgsql-get-value result i 0)) + numbers))) + ((= i n) + (pgsql-clear result) + (reverse! numbers)))))) + +(define (db-ps-problem-names ps-number) + (let ((result + (db-run-query "SELECT name" + " FROM registered_outputs" + " WHERE ps_number = " (db-quote ps-number)))) + (let ((n (pgsql-n-tuples result))) + (do ((i 0 (+ i 1)) + (names '() (cons (pgsql-get-value result i 0) names))) + ((= i n) + (pgsql-clear result) + names))))) + +(define (db-problem-submitted? ps-number name user-name) + (let ((result + (db-run-query "SELECT submitter" + " FROM saved_outputs" + " WHERE ps_number = " (db-quote ps-number) + " AND name = " (db-quote name) + " AND user_name = " (db-quote user-name)))) + (let ((submitted? + (and (> (pgsql-n-tuples result) 0) + (let ((v (pgsql-get-value result 0 0))) + (and v + (not (string-null? v))))))) + (pgsql-clear result) + submitted?))) + +(define (db-get-ps-structure) + (let ((result + (db-run-query "SELECT ps_number, ps_part, name" + " FROM registered_outputs" + " WHERE graded_p" + " ORDER BY ps_number, ps_part, name"))) + (let ((n (pgsql-n-tuples result))) + (do ((i 0 (+ i 1)) + (items '() + (cons (vector (string->number (pgsql-get-value result i 0)) + (pgsql-get-value result i 1) + (pgsql-get-value result i 2)) + items))) + ((= i n) + (pgsql-clear result) + (ps-structure->tree (reverse! items))))))) + +(define (ps-structure->tree items) + (map (lambda (pset) + (cons (vector-ref (car pset) 0) + (map (lambda (vs) + (cons (vector-ref (car vs) 1) + (map (lambda (v) (vector-ref v 2)) vs))) + (chop-into-pieces! pset + (lambda (a b) + (string=? (vector-ref a 1) (vector-ref b 1))))))) + (chop-into-pieces! items + (lambda (a b) + (= (vector-ref a 0) (vector-ref b 0)))))) + +(define (chop-into-pieces! items predicate) + (let loop ((items items) (pieces '())) + (if (pair? items) + (receive (head items) (chop-off-head! items predicate) + (loop items (cons head pieces))) + (reverse! pieces)))) + +(define (chop-off-head! head predicate) + (let loop ((items (cdr head)) (tail head)) + (if (pair? items) + (if (predicate (car items) (car head)) + (loop (cdr items) items) + (begin + (set-cdr! tail '()) + (values head items))) + (values head items)))) + +;;;; Saved inputs + +(define (db-previously-saved-input id) + (let ((result (db-run-query (saved-inputs-query id '(value submitter) #f)))) + (if (> (pgsql-n-tuples result) 0) + (let ((value (pgsql-get-value result 0 0)) + (submitter (pgsql-get-value result 0 1))) + (pgsql-clear result) + (values value (and submitter (string->symbol submitter)))) + (begin + (pgsql-clear result) + (values #f #f))))) + +(define (db-save-input! id value submitter) + (case (input-submission-status id #t) + ((#f) + (db-run-cmd "INSERT INTO saved_inputs VALUES" + " (" (db-quote *user-name*) + ", " (db-quote *ps-number*) + ", " (db-quote id) + ", " (db-quote value) + ", " (db-quote submitter) + ", " (db-quote (and submitter "NOW")) + ")")) + ((not-submitted) + (db-run-cmd "UPDATE saved_inputs SET" + " value = " (db-quote value) + ", submitter = " (db-quote submitter) + ", submission_time = " (db-quote (and submitter "NOW")) + " WHERE " (saved-inputs-condition id)))) + (db-run-cmd "INSERT INTO input_history VALUES" + " (" (db-quote *user-name*) + ", " (db-quote *ps-number*) + ", " (db-quote id) + ", " (db-quote "NOW") + ", " (db-quote value) + ")")) + +(define (input-submission-status id for-update?) + (let ((result + (db-run-query (saved-inputs-query id '(submitter) for-update?)))) + (let ((status + (and (> (pgsql-n-tuples result) 0) + (if (pgsql-get-is-null? result 0 0) + 'not-submitted + 'submitted)))) + (pgsql-clear result) + status))) + +(define (saved-inputs-query id fields for-update?) + (string-append "SELECT " (field-list->db-string fields) + " FROM saved_inputs" + " WHERE " (saved-inputs-condition id) + (if for-update? " FOR UPDATE" ""))) + +(define (saved-inputs-condition id) + (string-append "user_name = " (db-quote *user-name*) + " AND ps_number = " (db-quote *ps-number*) + " AND name = " (db-quote id))) + +;;;; Saved outputs + +(define (db-previously-saved-output id) + (let ((result + (db-run-query (saved-outputs-query id '(correctness submitter) #f)))) + (if (> (pgsql-n-tuples result) 0) + (let ((correctness (pgsql-get-value result 0 0)) + (submitter (pgsql-get-value result 0 1))) + (pgsql-clear result) + (values correctness (and submitter (string->symbol submitter)))) + (begin + (pgsql-clear result) + (values #f #f))))) + +(define (db-save-output! id correctness submitter late?) + (case (output-submission-status id #t) + ((#f) + (db-run-cmd "INSERT INTO saved_outputs VALUES" + " (" (db-quote *user-name*) + ", " (db-quote *ps-number*) + ", " (db-quote id) + ", " (db-quote correctness) + ", " (db-quote submitter) + ", " (if late? "TRUE" "FALSE") + ", " (db-quote (and submitter "NOW")) + ")")) + ((not-submitted) + (db-run-cmd "UPDATE saved_outputs SET" + " correctness = " (db-quote correctness) + ", submitter = " (db-quote submitter) + ", late_p = " (if late? "TRUE" "FALSE") + ", submission_time = " (db-quote (and submitter "NOW")) + " WHERE " (saved-outputs-condition id))))) + +(define (output-submission-status id for-update?) + (let ((result + (db-run-query (saved-outputs-query id '(submitter) for-update?)))) + (let ((status + (and (> (pgsql-n-tuples result) 0) + (if (pgsql-get-is-null? result 0 0) + 'not-submitted + 'submitted)))) + (pgsql-clear result) + status))) + +(define (saved-outputs-query id fields for-update?) + (string-append "SELECT " (field-list->db-string fields) + " FROM saved_outputs" + " WHERE " (saved-outputs-condition id) + (if for-update? " FOR UPDATE" ""))) + +(define (saved-outputs-condition id) + (string-append "user_name = " (db-quote *user-name*) + " AND ps_number = " (db-quote *ps-number*) + " AND name = " (db-quote id))) + +(define (db-get-saved-output user-name ps-number name) + (let ((result + (db-run-query "SELECT correctness, submitter, late_p" + " FROM saved_outputs" + " WHERE user_name = " (db-quote user-name) + " AND ps_number = " (db-quote ps-number) + " AND name = " (db-quote name)))) + (if (> (pgsql-n-tuples result) 0) + (let ((correctness (pgsql-get-value result 0 0)) + (submitter (pgsql-get-value result 0 1)) + (late? (string=? (pgsql-get-value result 0 2) "t"))) + (pgsql-clear result) + (values correctness + (and submitter (string->symbol submitter)) + late?)) + (begin + (pgsql-clear result) + (values #f #f #f))))) + +;;;; Persistent values + +(define (db-get-persistent-value name default) + (get-persistent-value name *page-key* default)) + +(define (db-set-persistent-value! name object) + (set-persistent-value! name *page-key* object)) + +(define (db-intern-persistent-value! name get-object) + (intern-persistent-value! name *page-key* get-object)) + +(define (db-delete-persistent-value! name) + (delete-persistent-value! name *page-key*)) + +(define (db-get-global-value name default) + (get-persistent-value name global-page-key default)) + +(define (db-set-global-value! name object) + (set-persistent-value! name global-page-key object)) + +(define (db-intern-global-value! name get-object) + (intern-persistent-value! name global-page-key get-object)) + +(define (db-delete-global-value! name) + (delete-persistent-value! name global-page-key)) + +(define global-page-key + "*global-page-key*") + +(define (get-persistent-value name page-key default) + (let ((result + (db-run-query + (persistent-value-query name page-key '(var_value) #f)))) + (let ((string + (and (> (pgsql-n-tuples result) 0) + (pgsql-get-value result 0 0)))) + (pgsql-clear result) + (if string + (read (open-input-string string)) + default)))) + +(define (set-persistent-value! name page-key object) + (let ((value (write-to-string object)) + (result + (db-run-query + (persistent-value-query name page-key '(var_value) #t)))) + (if (> (pgsql-n-tuples result) 0) + (let ((same-value? (string=? (pgsql-get-value result 0 0) value))) + (pgsql-clear result) + (if (not same-value?) + (db-run-cmd "UPDATE persistent_values SET" + " var_value = " + (db-quote value) + " WHERE " + (persistent-value-condition name page-key)))) + (begin + (pgsql-clear result) + (db-run-cmd "INSERT INTO persistent_values VALUES" + " (" (db-quote *user-name*) + ", " (db-quote page-key) + ", " (db-quote name) + ", " (db-quote value) + ")"))))) + +(define (intern-persistent-value! name page-key get-object) + (let ((result + (db-run-query + (persistent-value-query name page-key '(var_value) #t)))) + (if (> (pgsql-n-tuples result) 0) + (let ((value (pgsql-get-value result 0 0))) + (pgsql-clear result) + (read (open-input-string value))) + (begin + (pgsql-clear result) + (let ((object (get-object))) + (db-run-cmd "INSERT INTO persistent_values VALUES" + " (" (db-quote *user-name*) + ", " (db-quote page-key) + ", " (db-quote name) + ", " (db-quote (write-to-string object)) + ")") + object))))) + +(define (delete-persistent-value! name page-key) + (db-run-cmd "DELETE FROM persistent_values WHERE " + (persistent-value-condition name page-key))) + +(define (persistent-value-query name page-key fields for-update?) + (string-append "SELECT " (field-list->db-string fields) + " FROM persistent_values" + " WHERE " (persistent-value-condition name page-key) + (if for-update? " FOR UPDATE" ""))) + +(define (persistent-value-condition name page-key) + (string-append "user_name = " (db-quote *user-name*) + " AND file_name = " (db-quote page-key) + " AND var_name = " (db-quote name))) + +;;;; Clear submitted/late + +(define (db-saved-submitters user-name) + (db-marked-submitters user-name "submitter IS NOT NULL")) + +(define (db-late-submitters user-name) + (db-marked-submitters user-name "late_p")) + +(define (db-marked-submitters user-name condition) + (let ((result + (db-run-query "SELECT DISTINCT ps_number, submitter" + " FROM saved_outputs" + " WHERE user_name = " (db-quote user-name) + " AND " condition + " ORDER BY ps_number, submitter"))) + (let ((n (pgsql-n-tuples result))) + (let loop ((i 0) (names '())) + (if (< i n) + (loop (+ i 1) + (let ((submitter (pgsql-get-value result i 1))) + (if submitter + (cons (string-append (pgsql-get-value result i 0) + "/" + submitter) + names) + names))) + (begin + (pgsql-clear result) + (reverse! names))))))) + +(define (db-clear-submitter user-name number) + (receive (ps-number submitter) (parse-problem-number number) + (db-run-cmd "UPDATE saved_inputs" + " SET submitter = NULL" + " WHERE user_name = " (db-quote user-name) + " AND ps_number = " (db-quote ps-number) + " AND submitter = " (db-quote submitter)) + (db-set-output-field user-name ps-number submitter + "submitter = NULL"))) + +(define (db-clear-late-flag user-name number) + (receive (ps-number submitter) (parse-problem-number number) + (db-set-output-field user-name ps-number submitter "late_p = FALSE"))) + +(define (db-set-output-field user-name ps-number submitter assignment) + (let ((result + (db-run-query "UPDATE saved_outputs" + " SET " assignment + " WHERE user_name = " (db-quote user-name) + " AND ps_number = " (db-quote ps-number) + " AND submitter = " (db-quote submitter)))) + (let ((n (pgsql-cmd-tuples result))) + (pgsql-clear result) + n))) + +;;;; Users + +(define (db-known-user? user-name) + (known-user? user-name #f)) + +(define (known-user? user-name for-update?) + (let ((result + (db-run-query "SELECT enabled_p" + " FROM users" + " WHERE user_name = " (db-quote user-name) + (if for-update? " FOR UPDATE" "")))) + (if (> (pgsql-n-tuples result) 0) + (let ((enabled? + (if (string=? (pgsql-get-value result 0 0) "t") + #t + 'disabled))) + (pgsql-clear result) + enabled?) + (begin + (pgsql-clear result) + #f)))) + +(define (guarantee-known-user user-name) + (if (not (known-user? user-name #t)) + (error "Unknown user:" user-name))) + +(define (db-known-users condition) + (let ((result + (db-run-query "SELECT user_name" + " FROM users" + (case condition + ((enabled) " WHERE enabled_p") + ((disabled) " WHERE NOT enabled_p") + (else "")) + " ORDER BY user_name"))) + (let ((n (pgsql-n-tuples result))) + (let loop ((i 0) (users '())) + (if (< i n) + (loop (+ i 1) (cons (pgsql-get-value result i 0) users)) + (begin + (pgsql-clear result) + (reverse! users))))))) + +(define (db-new-user-account user-name first-names last-name password enabled?) + (if (known-user? user-name #t) + #f + (begin + (db-run-cmd "INSERT INTO users VALUES" + " (" (db-quote user-name) + ", " (db-quote first-names) + ", " (db-quote last-name) + ", " (db-quote (encrypt-password password)) + ", " "FALSE" + ", " (if enabled? "TRUE" "FALSE") + ")") + #t))) + +(define (db-change-user-password user-name password) + (guarantee-known-user user-name) + (db-run-cmd "UPDATE users" + " SET password = " (db-quote (encrypt-password password)) + " WHERE user_name = " (db-quote user-name))) + +(define (db-user-real-name user-name) + (let ((result + (db-run-query "SELECT first_names, last_name" + " FROM users" + " WHERE user_name = " (db-quote user-name)))) + (if (> (pgsql-n-tuples result) 0) + (let ((first (pgsql-get-value result 0 0)) + (last (pgsql-get-value result 0 1))) + (pgsql-clear result) + (values first last)) + (begin + (pgsql-clear result) + (error "Unknown user:" user-name) + (values #f #f))))) + +(define (db-set-user-real-name user-name first-names last-name) + (guarantee-known-user user-name) + (db-run-cmd "UPDATE users" + " SET first_names = " (db-quote first-names) + ", last_name = " (db-quote last-name) + " WHERE user_name = " (db-quote user-name))) + +(define (db-user-enabled? user-name) + (get-user-flag user-name "enabled_p")) + +(define (db-user-administrator? user-name) + (get-user-flag user-name "administrator_p")) + +(define (db-set-user-enabled user-name value) + (set-user-flag user-name "enabled_p" value)) + +(define (db-set-user-administrator user-name value) + (set-user-flag user-name "administrator_p" value)) + +(define (get-user-flag user-name flag-name) + (let ((result + (db-run-query "SELECT " flag-name + " FROM users" + " WHERE user_name = " (db-quote user-name)))) + (let ((string + (and (> (pgsql-n-tuples result) 0) + (pgsql-get-value result 0 0)))) + (pgsql-clear result) + (if (not string) + (error "Unknown user:" user-name)) + (string=? string "t")))) + +(define (set-user-flag user-name flag-name value) + (guarantee-known-user user-name) + (db-run-cmd "UPDATE users" + " SET " flag-name " = " (if value "TRUE" "FALSE") + " WHERE user_name = " (db-quote user-name))) + +(define (encrypt-password password) + (if (not (db-valid-password? password)) + (error "Invalid password syntax:" password)) + (let ((pw-line + (call-with-output-string + (lambda (port) + (let ((status + (run-shell-command (string-append "htpasswd -nb foo " + password) + 'output port))) + (if (not (= status 0)) + (error "Non-zero status from htpasswd:" status))))))) + (if (not (and (string-prefix? "foo:" pw-line) + (string-suffix? "\n" pw-line))) + (error "Unknown result from htpasswd:" pw-line)) + (substring pw-line 4 (fix:- (string-length pw-line) 1)))) + +(define (db-valid-password? string) + (and (fix:>= (string-length string) 8) + (not (string-find-next-char-in-set string char-set:not-password)) + (string-find-next-char-in-set string char-set:lower-case) + (string-find-next-char-in-set string char-set:upper-case) + (string-find-next-char-in-set string char-set:numeric))) + +(define char-set:password + (char-set-union char-set:alphanumeric + (string->char-set " _-."))) + +(define char-set:not-password + (char-set-invert char-set:password)) + +(define (db-generate-password) + (string-append (string (integer->char (+ (char->integer #\A) (random 26)))) + (string (integer->char (+ (char->integer #\a) (random 26)))) + (random-digit-string 6))) + +(define (random-digit-string n-chars) + (string-pad-left (number->string (random (expt 10 n-chars))) n-chars #\0)) + +(define (parse-problem-number string) + (let ((regs (re-string-match problem-number-regexp string))) + (if (not regs) + (error:bad-range-argument string 'parse-problem-number)) + (values (string->number (re-match-extract string regs 1)) + (re-match-extract string regs 2)))) + +(define problem-number-regexp + (rexp-compile + (let ((int + (rexp-sequence (char-set-difference char-set:numeric (char-set #\0)) + (rexp* char-set:numeric)))) + (rexp-sequence (rexp-string-start) + (rexp-group int) + "/" + (rexp-group (rexp-optional "xdoc_") int (rexp* "." int)) + (rexp-string-end))))) + +(define (field-list->db-string fields) + (apply string-append + (cons (symbol->string (car fields)) + (map (lambda (value) + (string-append ", " (symbol->string value))) + (cdr fields))))) \ No newline at end of file diff --git a/v7/src/xdoc/load.scm b/v7/src/xdoc/load.scm new file mode 100644 index 000000000..7cb44705e --- /dev/null +++ b/v7/src/xdoc/load.scm @@ -0,0 +1,32 @@ +#| -*-Scheme-*- + +$Id: load.scm,v 1.1 2004/11/01 19:21:05 cph Exp $ + +Copyright 2004 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +USA. + +|# + +;;;; XDOC loader + +(load-option 'ssp) +(with-working-directory-pathname (directory-pathname (current-load-pathname)) + (lambda () + (package/system-loader "xdoc" '() 'query))) +(add-subsystem-identification! "XDOC" '(0 3)) \ No newline at end of file diff --git a/v7/src/xdoc/validate-xdoc.scm b/v7/src/xdoc/validate-xdoc.scm new file mode 100644 index 000000000..a8e81b62c --- /dev/null +++ b/v7/src/xdoc/validate-xdoc.scm @@ -0,0 +1,461 @@ +#| -*-Scheme-*- + +$Id: validate-xdoc.scm,v 1.1 2004/11/01 19:21:05 cph Exp $ + +Copyright 2003 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +USA. + +|# + +;;;; XDOC implementation + +(declare (usual-integrations)) + +;;; **** Belongs in runtime: +(define (count-matching-items items predicate) + (do ((items items (cdr items)) + (n 0 (if (predicate (car items)) (+ n 1) n))) + ((not (pair? items)) n))) + +(define (validate-xdoc pathname) + (with-xdoc-expansion-context (pathname->ps-number pathname) pathname + (lambda (document) + (let ((root (xml-document-root document))) + (if (not (xd:xdoc? root)) + (vx:error root "Root element not .")) + (check-element root 'xdoc))))) + +(define (check-element elt local) + (let ((v (hash-table/get element-checkers local #f))) + (if (not v) + (error "Missing element definition:" local)) + (let ((valid-attrs? (vector-ref v 0)) + (type (vector-ref v 1)) + (valid-local? (vector-ref v 2)) + (procedure (vector-ref v 3))) + (if valid-attrs? + (valid-attrs? elt)) + (check-element-content elt type valid-local?) + (if procedure + (procedure elt))))) + +(define (check-element-content elt type procedure) + (case type + ((empty) + (if (not (null? (xml-element-contents elt))) + (vx:error elt "Empty element has content."))) + ((element) + (procedure elt)) + (else + (for-each (case type + ((text) + (lambda (item) + (if (not (string? item)) + (vx:content-error elt item)))) + ((html) + (lambda (item) + (if (xdoc-element? item) + (vx:content-error elt item)))) + ((mixed) + (lambda (item) + (let ((local (xdoc-element-name item))) + (if local + (if (content-predicate local) + (check-element item local) + (vx:content-error elt item)))))) + (else + (error "Unknown content type:" type))) + (xml-element-contents elt))))) + +(define (define-element-checker local type + #!optional valid-attrs? valid-local? procedure) + (let ((valid-attrs? (if (default-object? valid-attrs?) #f valid-attrs?)) + (valid-local? (if (default-object? valid-local?) #f valid-local?)) + (procedure (if (default-object? procedure) #f procedure))) + (if (and (memq type '(element mixed)) + (not valid-local?)) + (error "Must supply a name predicate with this content type:" type)) + (hash-table/put! element-checkers + local + (vector valid-attrs? type valid-local? procedure)))) + +(define element-checkers + (make-eq-hash-table)) + +(define (vx:standard-attrs elt) + (vx:optional-attr 'class elt vx:nmtokens) + (vx:optional-attr 'style elt vx:style)) + +;;;; Containers + +(define (vx:container-attrs elt) + (vx:standard-attrs elt) + (vx:optional-attr 'id elt vx:id)) + +(define (problem-element-name? local) + (or (memq local '(problem answer)) + (answer-element-name? local))) + +(define (answer-element-name? local) + (or (input-checker-element-name? local) + (switched-output-name? local) + (button-element-name? local))) + +(define-element-checker 'xdoc 'mixed + (lambda (elt) + (vx:container-attrs elt) + (vx:optional-attr 'number-format elt vx:procedure-name) + (vx:optional-attr 'problem-separator elt vx:boolean) + (vx:required-attr 'problem-set elt vx:nonnegative-integer) + (vx:optional-attr 'first-problem elt vx:problem-number) + (vx:optional-attr 'form-url elt vx:url)) + (lambda (local) + (or (problem-element-name? local) + (memq local '(due-date head)))) + (lambda (elt) + (if (> (count-matching-items (xml-element-contents elt) xd:due-date?) 1) + (vx:error elt "Multiple xd:due-date elements.")))) + +(define-element-checker 'head 'html) + +(define-element-checker 'due-date 'empty + (lambda (elt) + (vx:standard-attrs elt) + (vx:optional-attr 'year elt vx:year) + (vx:required-attr 'month elt vx:month) + (vx:required-attr 'day elt vx:day) + (vx:required-attr 'hour elt vx:hour) + (vx:optional-attr 'minute elt vx:minute))) + +(define-element-checker 'problem 'mixed + (lambda (elt) + (vx:container-attrs elt) + (vx:optional-attr 'number-format elt vx:procedure-name) + (vx:optional-attr 'number-type elt vx:number-type) + (vx:optional-attr 'problem-separator elt vx:boolean)) + (lambda (local) + (problem-element-name? local))) + +(define-element-checker 'answer 'element + (lambda (elt) + (vx:container-attrs elt)) + (lambda (local) + (or (answer-element-name? local) + (input-element-name? local) + (eq? local 'label)))) + +(define-element-checker 'label 'html + (lambda (elt) + (vx:standard-attrs elt))) + +;;;; Inputs + +(define (input-element-name? local) + (memq local '(checkbox menu radio-buttons text true-false))) + +(define (vx:input-attrs elt) + (vx:standard-attrs elt) + (vx:optional-attr 'width elt vx:positive-integer)) + +(define-element-checker 'text 'empty + (lambda (elt) + (vx:input-attrs elt))) + +(define-element-checker 'menu 'element + (lambda (elt) + (vx:input-attrs elt) + (vx:optional-attr 'size elt vx:positive-integer)) + (lambda (local) + (eq? local 'menuitem))) + +(define-element-checker 'menuitem 'text) + +(define-element-checker 'true-false 'empty + (lambda (elt) + (vx:input-attrs elt))) + +(define-element-checker 'checkbox 'empty + (lambda (elt) + (vx:input-attrs elt))) + +(define-element-checker 'radio-buttons 'element + (lambda (elt) + (vx:input-attrs elt)) + (lambda (local) + (eq? local 'radio-entry))) + +(define-element-checker 'radio-entry 'html + (lambda (elt) + (vx:input-attrs elt) + (vx:required-attr 'value elt vx:nmtoken))) + +;;;; Input checkers + +(define (input-checker-element-name? local) + (memq local '(boolean check-input check-inputs menuindex number))) + +(define (vx:unary-checker-attrs elt) + (vx:optional-attr 'id elt vx:id) + (vx:optional-attr 'source elt vx:idref)) + +(define (vx:n-ary-checker-attrs elt) + (vx:optional-attr 'id elt vx:id) + (vx:optional-attr 'sources elt vx:idrefs)) + +(define-element-checker 'check-input 'empty + (lambda (elt) + (vx:unary-checker-attrs elt) + (vx:optional-attr 'expected elt vx:cdata) + (vx:optional-attr 'checkable elt vx:boolean) + (vx:required-attr 'name elt vx:procedure-name))) + +(define-element-checker 'check-inputs 'empty + (lambda (elt) + (vx:n-ary-checker-attrs elt) + (vx:optional-attr 'expected elt vx:cdata) + (vx:optional-attr 'checkable elt vx:boolean) + (vx:required-attr 'name elt vx:procedure-name))) + +(define-element-checker 'number 'empty + (lambda (elt) + (vx:unary-checker-attrs elt) + (vx:required-attr 'expected elt vx:number) + (vx:optional-attr 'checkable elt vx:boolean) + (vx:optional-attr 'tolerance elt vx:number))) + +(define-element-checker 'boolean 'empty + (lambda (elt) + (vx:unary-checker-attrs elt) + (vx:required-attr 'expected elt vx:boolean))) + +(define-element-checker 'menuindex 'empty + (lambda (elt) + (vx:unary-checker-attrs elt) + (vx:required-attr 'expected elt vx:positive-integer))) + +;;;; Switched elements + +(define (switched-output-name? local) + (memq local '(case expected-value explain hint when))) + +(define (vx:switched-output-attrs elt) + (vx:standard-attrs elt) + (vx:optional-attr 'source elt vx:idref)) + +(define-element-checker 'explain 'html + (lambda (elt) + (vx:switched-output-attrs elt))) + +(define-element-checker 'hint 'html + (lambda (elt) + (vx:switched-output-attrs elt))) + +(define-element-checker 'expected-value 'empty + (lambda (elt) + (vx:switched-output-attrs elt))) + +(define-element-checker 'when 'html + (lambda (elt) + (vx:switched-output-attrs elt) + (vx:required-attr 'condition elt + (lambda (string) + (vx:test (lambda (string) + (or (string=? string "submitted") + (string=? string "not-submitted"))) + string + "condition"))))) + +(define-element-checker 'case 'element + (lambda (elt) + (vx:standard-attrs elt)) + (lambda (local) + (or (input-checker-element-name? local) + (eq? local 'refer) + (eq? local 'choice) + (eq? local 'default))) + (lambda (elt) + (if (not (case-element-children? (xml-element-contents elt))) + (vx:error elt "Invalid arrangement of child elements.")))) + +(define-element-checker 'refer 'empty + (lambda (elt) + (vx:required-attr 'source elt vx:idref))) + +(define-element-checker 'choice 'html + (lambda (elt) + (vx:required-attr 'values elt vx:nmtokens))) + +(define-element-checker 'default 'html) + +;;;; Buttons + +(define (button-element-name? local) + (memq local '(check-button submit-button))) + +(define (vx:button-attrs elt) + (vx:standard-attrs elt) + (vx:optional-attr 'scope elt vx:idref)) + +(define-element-checker 'check-button 'empty + (lambda (elt) + (vx:button-attrs elt))) + +(define-element-checker 'submit-button 'empty + (lambda (elt) + (vx:button-attrs elt))) + +;;;; Attribute tests + +(define (vx:required-attr name elt test) + (let ((attr (%find-attribute name (xml-element-attributes elt)))) + (if attr + (vx:check-attr test attr elt) + (vx:error "Missing required attribute: " name elt)))) + +(define (vx:optional-attr name elt test) + (let ((attr (%find-attribute name (xml-element-attributes elt)))) + (if attr + (vx:check-attr test attr elt)))) + +(define (vx:check-attr test attr elt) + (let ((desc (test (xml-attribute-value attr)))) + (if desc + (vx:error elt + "Attribute " + (xml-attribute-name attr) + " value should be " + desc + ":" + (xml-attribute-value attr))))) + +(define ((vx:tester desc predicate) string) + (if (predicate string) + #f + desc)) + +(define (vx:number-tester desc predicate) + (vx:tester desc + (lambda (string) + (predicate (string->number string))))) + +(define (vx:index-tester desc k l) + (vx:number-tester desc + (lambda (n) + (and (exact-integer? n) + (<= k n l))))) + +(define vx:cdata (vx:tester "XML string" xml-char-data?)) +(define vx:id (vx:tester "ID" string-is-xml-name?)) +(define vx:idref (vx:tester "ID reference" string-is-xml-name?)) +(define vx:nmtoken (vx:tester "XML token" string-is-xml-nmtoken?)) + +(define vx:idrefs + (vx:tester "ID references" + (lambda (string) + (for-all? (burst-string string char-set:whitespace #t) + string-is-xml-name?)))) + +(define vx:nmtokens + (vx:tester "XML tokens" + (lambda (string) + (for-all? (burst-string string char-set:whitespace #t) + string-is-xml-nmtoken?)))) + +(define vx:boolean + (vx:tester "true or false" + (lambda (string) + (or (string=? string "true") + (string=? string "false"))))) + +(define vx:style + (vx:tester "style sheet" + (lambda (string) + string + #t))) + +(define vx:url + (vx:tester "URL" + (lambda (string) + string + #t))) + +(define vx:number + (vx:number-tester "number" number?)) + +(define vx:nonnegative-integer + (vx:number-tester "non-negative integer" exact-nonnegative-integer?)) + +(define vx:positive-integer + (vx:number-tester "positive integer" exact-positive-integer?)) + +(define vx:minute (vx:index-tester "minute" 0 59)) +(define vx:hour (vx:index-tester "hour" 0 59)) +(define vx:day (vx:index-tester "day of month" 1 31)) +(define vx:month (vx:index-tester "month" 1 12)) +(define vx:year (vx:number-tester "year" exact-nonnegative-integer?)) + +(define vx:problem-number + (vx:tester "problem number" + (lambda (string) + (re-string-match "\\`\\([1-9][0-9]*.\\)*[1-9][0-9]*\\'" string)))) + +(define vx:number-type + (vx:tester "problem-number format type" + (lambda (string) + (or (string=? string "dl") + (string=? string "ol") + (string=? string "ul") + (string=? string "none"))))) + +(define vx:procedure-name + (vx:tester "procedure name" xdoc-procedure-name?)) + +(define (vx:content-error elt item) + (vx:error elt "Illegal content: " item)) + +(define (vx:error elt msg . msg-items) + (error:xdoc-validation elt (cons msg msg-items))) + +(define condition-type:xdoc-validation-error + (make-condition-type 'xdoc-validation-error + condition-type:warning + '(element message-items) + (lambda (condition port) + (write-string "Error validating " port) + (write (xdoc-validation-error/element condition) port) + (write-string ": " port) + (let loop ((items (xdoc-validation-error/message-items condition))) + (if (pair? items) + (begin + (write-string (car items) port) + (if (pair? (cdr items)) + (begin + (write (cadr items) port) + (loop (cddr items)))))))))) + +(define xdoc-validation-error/element + (condition-accessor condition-type:xdoc-validation-error 'element)) + +(define xdoc-validation-error/message-items + (condition-accessor condition-type:xdoc-validation-error 'message-items)) + +(define error:xdoc-validation + (condition-signaller condition-type:xdoc-validation-error + '(element message-items) + standard-warning-handler)) \ No newline at end of file diff --git a/v7/src/xdoc/xdoc.pkg b/v7/src/xdoc/xdoc.pkg new file mode 100644 index 000000000..9392ca151 --- /dev/null +++ b/v7/src/xdoc/xdoc.pkg @@ -0,0 +1,215 @@ +#| -*-Scheme-*- + +$Id: xdoc.pkg,v 1.1 2004/11/01 19:21:05 cph Exp $ + +Copyright 2004 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +USA. + +|# + +;;;; XDOC: packaging + +(global-definitions "../runtime/runtime") +(global-definitions "../xml/xml") +(global-definitions "../ssp/ssp") + +(define-package (runtime ssp xdoc) + (files "xdoc") + (parent (runtime ssp)) + (export (runtime ssp) + boolean-attribute + int0-attribute + with-xdoc-expansion-context + xd:answer + xd:answer? + xd:boolean + xd:boolean? + xd:case + xd:case? + xd:check-input + xd:check-input? + xd:check-inputs + xd:check-inputs? + xd:checkbox + xd:checkbox? + xd:choice + xd:choice? + xd:default + xd:default? + xd:due-date + xd:due-date? + xd:expected-value + xd:expected-value? + xd:explain + xd:explain? + xd:head + xd:head? + xd:hint + xd:hint? + xd:label + xd:label? + xd:menu + xd:menu? + xd:menuindex + xd:menuindex? + xd:menuitem + xd:menuitem? + xd:number + xd:number? + xd:page-frame + xd:page-frame? + xd:problem + xd:problem? + xd:programmed-output + xd:programmed-output? + xd:radio-buttons + xd:radio-buttons? + xd:radio-entry + xd:radio-entry? + xd:refer + xd:refer? + xd:submit + xd:submit? + xd:text + xd:text? + xd:true-false + xd:true-false? + xd:when + xd:when? + xd:xdoc + xd:xdoc? + xdoc-db-id + xdoc-output?) + (export (runtime ssp-expander-environment) + find-xdoc-due-date + with-xdoc-expansion-context + xd:answer + xd:answer? + xd:boolean + xd:boolean? + xd:case + xd:case? + xd:check-input + xd:check-input? + xd:check-inputs + xd:check-inputs? + xd:checkbox + xd:checkbox? + xd:choice + xd:choice? + xd:default + xd:default? + xd:due-date + xd:due-date? + xd:expected-value + xd:expected-value? + xd:explain + xd:explain? + xd:head + xd:head? + xd:hint + xd:hint? + xd:label + xd:label? + xd:menu + xd:menu? + xd:menuindex + xd:menuindex? + xd:menuitem + xd:menuitem? + xd:number + xd:number? + xd:page-frame + xd:page-frame? + xd:problem + xd:problem? + xd:programmed-output + xd:programmed-output? + xd:radio-buttons + xd:radio-buttons? + xd:radio-entry + xd:radio-entry? + xd:refer + xd:refer? + xd:submit + xd:submit? + xd:text + xd:text? + xd:true-false + xd:true-false? + xd:when + xd:when? + xd:xdoc + xd:xdoc? + xdoc-due-date-attributes + xdoc-due-date-string + xdoc-outputs-submitted? + xdoc-part-number + xdoc-ps-number + xdoc-recursive?)) + +(define-package (runtime ssp database-interface) + (files "db") + (parent (runtime ssp)) + (export (runtime ssp) + close-database + with-database-connection) + (export (runtime ssp xdoc) + db-delete-persistent-value! + db-get-persistent-value + db-intern-persistent-value! + db-previously-saved-input + db-previously-saved-output + db-save-input! + db-save-output! + db-set-persistent-value!) + (export (runtime ssp-expander-environment) + db-change-user-password + db-clear-late-flag + db-clear-submitter + db-delete-global-value! + db-delete-persistent-value! + db-generate-password + db-get-global-value + db-get-persistent-value + db-get-ps-structure + db-get-saved-output + db-intern-global-value! + db-intern-persistent-value! + db-known-user? + db-known-users + db-late-submitters + db-new-user-account + db-problem-submitted? + db-ps-problem-names + db-quote + db-register-problem-set + db-registered-problem-sets + db-run-cmd + db-run-query + db-saved-submitters + db-set-global-value! + db-set-persistent-value! + db-set-user-administrator + db-set-user-enabled + db-set-user-real-name + db-user-administrator? + db-user-enabled? + db-user-real-name + db-valid-password?)) \ No newline at end of file diff --git a/v7/src/xdoc/xdoc.scm b/v7/src/xdoc/xdoc.scm new file mode 100644 index 000000000..5f0d36a2d --- /dev/null +++ b/v7/src/xdoc/xdoc.scm @@ -0,0 +1,1534 @@ +#| -*-Scheme-*- + +$Id: xdoc.scm,v 1.1 2004/11/01 19:21:05 cph Exp $ + +Copyright 2003,2004 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme 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. + +MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +USA. + +|# + +;;;; XDOC implementation + +(declare (usual-integrations)) + +(define *in-xdoc-context?* #f) +(define *xdoc-recursive?*) +(define *xdoc-ps-number*) +(define *xdoc-environment*) +(define *xdoc-root*) +(define *xdoc-late?*) +(define *xdoc-element-properties*) +(define *xdoc-id-map*) +(define *xdoc-inputs*) +(define *xdoc-outputs*) +(define *trace-expansion-port* #f) + +(define-mime-handler '(application/xdoc+xml "xdoc") + (lambda (pathname port) + (http-response-header 'content-type (html-content-type)) + (write-xml + (with-xdoc-expansion-context (pathname->ps-number pathname) pathname + (lambda (document) + (memoize-xdoc-inputs) + (memoize-xdoc-outputs) + (let ((pad-misc + (lambda (misc) + (cons "\n" + (append-map! (lambda (item) (list item "\n")) + misc))))) + (make-xml-document (or (xml-document-declaration document) + (make-xml-declaration "1.0" "UTF-8" #f)) + (pad-misc + (cons (mathml-stylesheet) + (xml-document-misc-1 document))) + html-dtd + (pad-misc (xml-document-misc-2 document)) + (generate-xdoc-html (xml-document-root document)) + (pad-misc (xml-document-misc-3 document)))))) + port + 'indent-dtd? #t + 'indent-attributes? #t))) + +(define (mathml-stylesheet) + (make-xml-processing-instructions + 'xml-stylesheet + "type=\"text/xsl\" href=\"/styles/mathml.xsl\"")) + +(define (pathname->ps-number pathname) + (let ((s (car (last-pair (pathname-directory pathname))))) + (let ((regs (re-string-match "\\`ps\\([0-9]+\\)\\'" s #t))) + (if regs + (string->number (re-match-extract s regs 1)) + 0)))) + +(define (with-xdoc-expansion-context ps-number pathname procedure) + (with-database-connection ps-number pathname + (lambda () + (let ((environment (make-expansion-environment pathname))) + (fluid-let ((*in-xdoc-context?* #t) + (*xdoc-recursive?* *in-xdoc-context?*) + (*xdoc-ps-number* ps-number) + (*xdoc-environment* environment) + (*xdoc-root*) + (*xdoc-late?*) + (*xdoc-element-properties* (make-eq-hash-table)) + (*xdoc-id-map* (make-eq-hash-table)) + (*xdoc-inputs* (make-eq-hash-table)) + (*xdoc-outputs* (make-eq-hash-table))) + (let ((document (read/expand-xml-file pathname environment))) + (set! *xdoc-root* (xml-document-root document)) + (set! *xdoc-late?* (due-date-in-past?)) + (xdoc-pre-passes document) + (if *trace-expansion-port* + (begin + (write-xml document *trace-expansion-port*) + (fresh-line *trace-expansion-port*) + (flush-output *trace-expansion-port*))) + (procedure document))))))) + +(define (trace-expansion filename) + (set! *trace-expansion-port* (open-output-file filename)) + unspecific) + +(define (untrace-expansion) + (let ((port *trace-expansion-port*)) + (set! *trace-expansion-port* #f) + (if port + (close-port port)))) + +;;;; Document analysis + +(define (xdoc-pre-passes document) + (strip-xdoc-space document) + (save-structure-properties (xml-document-root document))) + +(define (strip-xdoc-space document) + (let ((strip! + (lambda (object accessor modifier) + (modifier object + (delete-matching-items! (accessor object) xml-comment?)) + (modifier object + (delete-matching-items! (accessor object) + xml-whitespace-string?))))) + (strip! document xml-document-misc-1 set-xml-document-misc-1!) + (set-xml-document-dtd! document #f) + (strip! document xml-document-misc-2 set-xml-document-misc-2!) + (let loop ((elt (xml-document-root document))) + (if (memq (xdoc-content-type elt) '(empty element)) + (strip! elt xml-element-contents set-xml-element-contents!)) + (for-each (lambda (item) + (if (xml-element? item) (loop item))) + (xml-element-contents elt))) + (strip! document xml-document-misc-3 set-xml-document-misc-3!))) + +(define (save-structure-properties root) + (receive (prefix n) (ps-info root) + ;; Make unique top-level ID. + (save-container-props root '() (string-append "xdoc_" prefix) 1 (- n 1)) + (let ((id-generator + (lambda (suffix) + (let ((prefix + (string-append prefix (number->string n) suffix "-")) + (count 0)) + (lambda () + (let ((id + (string->symbol + (string-append prefix + (string-pad-left (number->string count) + 4 + #\0))))) + (set! count (+ count 1)) + id)))))) + (let ((get-misc-id (id-generator "")) + (get-input-id (id-generator "-input")) + (get-output-id (id-generator "-output"))) + (let walk-container + ((elt root) + (containers (list root)) + (prefix prefix) + (offset (- n 1))) + (let loop ((items (xml-element-contents elt)) (count 1)) + (if (pair? items) + (let ((item (car items))) + (if (xdoc-internal-container? item) + (begin + (walk-container item + (cons item containers) + (save-container-props item + containers + prefix + count + offset) + 0) + (loop (cdr items) (+ count 1))) + (begin + (let walk-html ((item item)) + (if (xdoc-container? item) + (error "No containers in HTML:" item)) + (if (xdoc-element? item) + (save-element-props + item containers + (cond ((xdoc-input? item) (get-input-id)) + ((xdoc-output? item) (get-output-id)) + (else (get-misc-id))))) + (if (xml-element? item) + (for-each walk-html + (xml-element-contents item)))) + (loop (cdr items) count))))))))))) + +(define (xdoc-recursive?) *xdoc-recursive?*) +(define (xdoc-ps-number) *xdoc-ps-number*) + +(define (xdoc-part-number name) + (if (string-prefix? "xdoc_" name) + (string-tail name 5) + name)) + +(define (ps-info elt) + (let ((no (find-attribute 'first-problem elt #f))) + (if no + (let ((regs + (re-string-match "\\`\\(\\([0-9]+.\\)*\\)\\([0-9]+\\)\\'" no))) + (if (not regs) + (error "Malformed first-problem attribute:" no)) + (values (re-match-extract no regs 1) + (string->number (re-match-extract no regs 3)))) + (values "" 1)))) + +(define (save-container-props elt containers prefix count offset) + (let ((number (+ count offset))) + (let ((db-id (string-append prefix (number->string number)))) + (hash-table/put! *xdoc-element-properties* elt + (vector (string->symbol db-id) + containers + prefix + number + count)) + (save-xdoc-id elt) + (string-append db-id ".")))) + +(define (save-element-props elt containers db-id) + (hash-table/put! *xdoc-element-properties* elt (vector db-id containers)) + (save-xdoc-id elt) + (cond ((xdoc-input? elt) + (hash-table/put! *xdoc-inputs* elt #f)) + ((xdoc-output? elt) + (hash-table/put! *xdoc-outputs* elt #f)))) + +(define (save-xdoc-id elt) + (let ((id (id-attribute 'id elt #f))) + (if id + (begin + (if (hash-table/get *xdoc-id-map* id #f) + (error "ID attribute not unique:" id)) + (hash-table/put! *xdoc-id-map* id elt))))) + +(define (xdoc-db-id elt) + (vector-ref (%xdoc-element-properties elt) 0)) + +(define (xdoc-element-containers elt) + (vector-ref (%xdoc-element-properties elt) 1)) + +(define (xdoc-element-properties elt) + (let ((v (%xdoc-element-properties elt))) + (values (vector-ref v 2) + (vector-ref v 3) + (length (vector-ref v 1)) + (vector-ref v 4)))) + +(define (%xdoc-element-properties elt) + (let ((v (hash-table/get *xdoc-element-properties* elt #f))) + (if (not v) + (error:wrong-type-argument elt "XDOC element" + 'xdoc-element-properties)) + v)) + +(define (nearest-container elt) + (let ((containers (xdoc-element-containers elt))) + (if (not (pair? containers)) + (error "Unable to find XDOC element container.")) + (car containers))) + +(define (named-element id) + (or (hash-table/get *xdoc-id-map* id #f) + (error:bad-range-argument id 'named-element))) + +;;;; I/O memoization + +(define (memoize-xdoc-inputs) + (for-each (lambda (elt) + (hash-table/put! *xdoc-inputs* elt (memoize-xdoc-input elt))) + (hash-table/key-list *xdoc-inputs*))) + +(define (memoize-xdoc-input elt) + (let ((id (xdoc-db-id elt))) + (receive (value submitter) (db-previously-saved-input id) + (if submitter + (cons value submitter) + (receive (value* submitter) (xdoc-active-input-status elt) + (let ((value (or value ""))) + (if (or submitter + (and value* (not (string=? value* value)))) + (db-save-input! id (or value* value) submitter)) + (cons (or value* value) submitter))))))) + +(define (memoize-xdoc-outputs) + (for-each (lambda (elt) + (receive (correctness submitter) (memoize-xdoc-output elt) + (hash-table/put! *xdoc-outputs* elt + (cons correctness submitter)))) + (hash-table/key-list *xdoc-outputs*))) + +(define (memoize-xdoc-output elt) + (let ((id (xdoc-db-id elt))) + (receive (correctness submitter) (db-previously-saved-output id) + (if submitter + (values correctness submitter) + (receive (correctness* submitter) (xdoc-active-output-status elt) + (let ((correctness (or correctness "unspecified"))) + (if (or submitter + (not (string=? correctness* correctness))) + (db-save-output! id + correctness* + submitter + *xdoc-late?*))) + (values correctness* submitter)))))) + +(define (current-input-status elt) + (let ((p (%current-input-status elt))) + (values (car p) (cdr p)))) + +(define (input-submitted? elt) + (and (cdr (%current-input-status elt)) #t)) + +(define (%current-input-status elt) + (or (hash-table/get *xdoc-inputs* elt #f) + (error:wrong-type-argument elt + "XDOC input element" + 'current-input-status))) + +(define (current-inputs-status sources) + (receive (value submitter) (current-input-status (car sources)) + (let loop + ((sources (cdr sources)) + (vals (list value)) + (submitter submitter)) + (if (pair? sources) + (receive (value submitter*) (current-input-status (car sources)) + (loop (cdr sources) + (cons value vals) + (and (eq? submitter* submitter) submitter))) + (values (reverse! vals) submitter))))) + +(define (current-output-status elt) + (let ((p (%current-output-status elt))) + (values (car p) (cdr p)))) + +(define (output-submitted? elt) + (and (cdr (%current-output-status elt)) #t)) + +(define (%current-output-status elt) + (or (hash-table/get *xdoc-outputs* elt #f) + (error:wrong-type-argument elt + "XDOC output element" + 'current-output-status))) + +;;;; HTML generator + +(define (generate-xdoc-html root) + (if (not (xd:xdoc? root)) + (error "Top level element must be :" root)) + (html:html (xdoc-attributes root 'xmlns html-iri) + "\n" + (html:head #f + "\n " + (html:style-link "/styles/xdoc.css") + (append-map (lambda (item) + (if (xd:head? item) + (xml-element-contents item) + '())) + (xml-element-contents root))) + "\n" + (html:body #f "\n" ((xdoc-html-generator root) root) "\n") + "\n")) + +(define (define-html-generator name handler) + (hash-table/put! html-generators name handler)) + +(define (xdoc-html-generator item) + (hash-table/get html-generators (xdoc-element-name item) #f)) + +(define html-generators + (make-xml-name-hash-table)) + +(define (generate-container-items items extra-content?) + (generate-container-groups + (parse-container-groups items xd:answer?) + (lambda (items) + (map (lambda (item) + (generate-item item extra-content?)) + items)) + generate-answer-block)) + +(define (generate-item item extra-content?) + (cond ((xdoc-element? item) + (if (not (or (memq (xdoc-element-type item) + '(output content-selector action)) + (extra-content? item))) + (error "Illegal content in this context:" item)) + (expand-xdoc item)) + ((xml-element? item) + (generate-xdoc-in-html item + (lambda (elt) + (if (not (memq (xdoc-element-type elt) + '(output content-selector action))) + (error "Illegal content in this context:" elt)) + (expand-xdoc elt)))) + (else item))) + +(define (expand-xdoc elt) + (let ((handler (xdoc-html-generator elt))) + (if (not handler) + (error "Unhandled element type:" (xml-element-name elt))) + (handler elt))) + +(define (generate-xdoc-in-html elt procedure) + (let loop ((elt elt)) + (make-xml-element (xml-element-name elt) + (xml-element-attributes elt) + (flatten-xml-element-contents + (map (lambda (item) + (cond ((xdoc-element? item) (procedure item)) + ((xml-element? item) (loop item)) + (else item))) + (xml-element-contents elt)))))) + +(define (generate-container-groups groups generate-even generate-odd) + (let loop ((groups groups)) + (if (pair? groups) + (cons (generate-even (car groups)) + (if (pair? (cdr groups)) + (cons (generate-odd (cadr groups)) + (loop (cddr groups))) + '())) + '()))) + +(define (parse-container-groups items container?) + (letrec + ((collect-non-containers + (lambda (items group groups) + (if (pair? items) + (if (container? (car items)) + (collect-containers (cdr items) + (list (car items)) + (cons (reverse! group) groups)) + (collect-non-containers (cdr items) + (cons (car items) group) + groups)) + (reverse! (cons (reverse! group) groups))))) + (collect-containers + (lambda (items group groups) + (if (pair? items) + (cond ((container? (car items)) + (collect-containers (cdr items) + (cons (car items) group) + groups)) + ((spacer? (car items)) + (skip-spacers (cdr items) + (list (car items)) + group + groups)) + (else + (collect-non-containers (cdr items) + (list (car items)) + (cons (reverse! group) groups)))) + (reverse! (cons (reverse! group) groups))))) + (skip-spacers + (lambda (items spacers group groups) + (if (pair? items) + (cond ((spacer? (car items)) + (skip-spacers (cdr items) + (cons (car items) spacers) + group + groups)) + ((container? (car items)) + (collect-containers (cdr items) + (cons (car items) + (append! spacers group)) + groups)) + (else + (collect-non-containers (cdr items) + (cons (car items) spacers) + (cons (reverse! group) groups)))) + (reverse! + (cons* (reverse! spacers) + (reverse! group) + groups))))) + (spacer? + (lambda (item) + (or (xml-whitespace-string? item) + (xml-comment? item))))) + (collect-non-containers items '() '()))) + +;;;; Containers + +(define-html-generator 'xdoc + (lambda (elt) + (int0-attribute 'problem-set elt #t) ;require attribute + (html:form (xml-attrs 'method 'post + 'action (or (find-attribute 'form-url elt #f) + (http-request-url))) + (generate-container-items + (if (confirming-submission? elt) + (keep-matching-items (xml-element-contents elt) + (lambda (item) + (or (xd:page-frame? item) + (xd:when? item)))) + (xml-element-contents elt)) + (lambda (elt) + (or (xd:head? elt) + (xd:page-frame? elt) + (xd:due-date? elt) + (xdoc-internal-container? elt))))))) + +(define-html-generator 'head + (lambda (elt) + elt + '())) + +(define-html-generator 'page-frame + (lambda (elt) + (xml-element-contents elt))) + +(define-html-generator 'due-date + (lambda (elt) + (let ((dt (due-date->decoded-time elt))) + (let ((s + ((or (procedure-attribute 'format elt #f) + xdoc-due-date-string) + dt))) + (and s + (html:p (merge-attributes (xdoc-due-date-attributes dt) + (preserved-attributes elt)) + s)))))) + +(define (due-date->decoded-time elt) + (make-decoded-time + 0 + (or (index0-attribute 'minute 60 elt #f) 0) + (index0-attribute 'hour 24 elt #t) + (index1-attribute 'day 31 elt #t) + (index1-attribute 'month 12 elt #t) + (numeric-attribute 'year + (lambda (z) + (and (exact-integer? z) + (>= z 1970))) + elt + #t))) + +(define (find-xdoc-due-date root error?) + (let ((elt (find-named-child 'due-date root error?))) + (and elt + (due-date->decoded-time elt)))) + +(define (xdoc-due-date-attributes dt) + (xml-attrs 'class + (list 'xdoc-due-date + (if (decoded-time-in-past? dt) + 'xdoc-due-date-overdue + 'xdoc-due-date-on-time)))) + +(define (xdoc-due-date-string dt) + (let ((hour (decoded-time/hour dt)) + (minute (decoded-time/minute dt))) + (string-append "Due: " + (day-of-week/long-string (decoded-time/day-of-week dt)) + " " + (month/short-string (decoded-time/month dt)) + ". " + (number->string (decoded-time/day dt)) + " at " + (number->string + (cond ((> hour 12) (- hour 12)) + ((> hour 0) hour) + (else 12))) + (if (> minute 0) + (string-append ":" (string-pad-left minute 2 #\0)) + "") + " " + (if (> hour 12) "PM" "AM")))) + +(define (due-date-in-past?) + (let ((dt (find-xdoc-due-date *xdoc-root* #f))) + (and dt + (decoded-time-in-past? dt)))) + +(define (decoded-time-in-past? dt) + (< (decoded-time->universal-time dt) (get-universal-time))) + +(define-html-generator 'problem + (lambda (elt) + (receive (prefix number depth count) (xdoc-element-properties elt) + (let ((formatter + (procedure-attribute 'number-format (nearest-container elt) #f)) + (body (generate-problem-body elt))) + (let ((class-attrs + (lambda (part) + (xml-attrs 'class + (let ((base (symbol 'xdoc-problem- part))) + (list base + (symbol base '- depth))))))) + (let ((label-attrs (class-attrs 'label)) + (body-attrs (class-attrs 'body))) + (list (if (and (> count 1) (problem-separator? elt)) + (list (html:hr) "\n") + '()) + (if (> depth 1) + (case (problem-group-type (nearest-container elt)) + ((dl) + (list (html:dt label-attrs + (if formatter + (formatter prefix number elt) + (list number ":"))) + "\n" + (html:dd body-attrs "\n" body))) + ((ol) + (html:li (xml-attrs body-attrs 'value number) + body)) + ((ul) (html:li body-attrs body)) + (else (html:div body-attrs body))) + (list (html:p label-attrs + (if formatter + (formatter prefix number elt) + (list "Problem " prefix number))) + "\n" + (html:div body-attrs "\n" body)))))))))) + +(define (generate-problem-body elt) + (let ((wrap + (case (problem-group-type elt) + ((dl) html:dl) + ((ol) html:ol) + ((ul) html:ul) + (else html:div))) + (attrs (xdoc-attributes elt 'class 'xdoc-problem-group)) + (generate-group + (lambda (items) + (generate-container-items items xdoc-internal-container?)))) + (generate-container-groups + (parse-container-groups (xml-element-contents elt) xd:problem?) + generate-group + (lambda (items) + (list "\n" + (wrap attrs "\n" (generate-group items))))))) + +(define (problem-group-type elt) + (if (find-attribute 'number-format elt #f) + 'dl + (let ((type (or (symbol-attribute 'number-type elt #f) 'ol))) + (if (not (memq type '(dl ol ul none))) + (error "Illegal number-type attribute:" type)) + type))) + +(define (problem-separator? elt) + (eq? (let ((elt (nearest-container elt))) + (or (boolean-attribute 'problem-separator elt #f) + (let ((local (xdoc-element-name elt))) + (case local + ((xdoc) 'true) + ((problem) 'false) + (else (error "Illegal container:" local)))))) + 'true)) + +(define (generate-answer-block elts) + (fluid-let ((*answer-block-appendixes* '())) + (let ((t + (html:table (xml-attrs 'class 'xdoc-answer-block + 'cellspacing "8") + (map (lambda (elt) + (list "\n " + (html:tr (xdoc-attributes elt) + (generate-answer-row elt) + "\n ") + "\n")) + elts)))) + ;; Let forces order of evaluation. + (cons t (reverse! *answer-block-appendixes*))))) + +(define (append-to-answer-block . items) + (set! *answer-block-appendixes* + (append! *answer-block-appendixes* items)) + unspecific) + +(define *answer-block-appendixes*) + +(define (generate-answer-row elt) + (append-map generate-answer-item + (xml-element-contents elt))) + +(define (generate-answer-item elt) + (let* ((name (xdoc-element-name elt))) + (if (not (or (memq (xdoc-element-type elt) + '(input output content-selector action)) + (xd:label? elt))) + (error "Unknown content:" elt)) + (let ((items + (flatten-xml-element-contents ((xdoc-html-generator elt) elt)))) + (if (null? items) + '() + (list "\n " + (html:td (xdoc-attributes elt + 'class (symbol 'xdoc-answer- name)) + "\n " + items + "\n ")))))) + +(define-html-generator 'label + (lambda (elt) + (xml-element-contents elt))) + +;;;; Inputs + +(define (define-xdoc-input local canonicalizer generator) + (hash-table/put! xdoc-input-canonicalizers local canonicalizer) + (define-html-generator local generator)) + +(define (xdoc-active-input-status elt) + (receive (request submitter) (xdoc-active-element-request elt) + (values (canonicalize-xdoc-input-value + elt + (http-request-post-parameter (xdoc-db-id elt)) + request) + (and (eq? request 'submit) submitter)))) + +(define (xdoc-active-element-request elt) + (let ((bindings (http-request-post-parameter-bindings))) + (let per-elt ((elt elt) (containers (xdoc-element-containers elt))) + (let* ((id (xdoc-db-id elt)) + (suffix (string-append "-" (symbol-name id)))) + (cond ((find-matching-item bindings + (lambda (binding) + (string-suffix? suffix (symbol-name (car binding))))) + => (lambda (binding) + (values (let ((name (symbol-name (car binding)))) + (substring->symbol + name + 0 + (fix:- (string-length name) + (string-length suffix)))) + id))) + ((pair? containers) + (per-elt (car containers) (cdr containers))) + (else + (values #f #f))))))) + +(define (canonicalize-xdoc-input-value elt value request) + (let ((local (xdoc-element-name elt))) + (if (eq? local 'checkbox) + (if (and (not value) request) "false" value) + (and value + ((or (hash-table/get xdoc-input-canonicalizers local #f) + (error:wrong-type-argument elt + "XDOC input element" + 'canonicalize-xdoc-input-value)) + value))))) + +(define xdoc-input-canonicalizers + (make-eq-hash-table)) + +(define-xdoc-input 'text + string-trim + (lambda (elt) + (receive (value submitter) (current-input-status elt) + (let ((width (int0-attribute 'width elt #t))) + (html:input 'class 'xdoc-text-input + 'type 'text + 'size width + 'maxlen width + 'name (xdoc-db-id elt) + 'value value + 'disabled (and submitter 'disabled)))))) + +(define-xdoc-input 'menu + (lambda (value) (if (string=? value menu-dummy-string) "" value)) + (lambda (elt) + (receive (value submitter) (current-input-status elt) + (let ((size (or (int1-attribute 'size elt #f) 1))) + (list + (html:select (xdoc-attributes elt + 'name (xdoc-db-id elt) + 'size size + 'disabled (and submitter 'disabled)) + "\n" + (html:option #f menu-dummy-string) + (map (lambda (v) + (list "\n" + (html:option + (xml-attrs 'selected (string=? v value)) + v))) + (xd:menu-values elt)) + "\n") + "\n"))))) + +(define menu-dummy-string + "--select answer--") + +(define (xd:menu-values elt) + (map (lambda (elt) + (if (not (xd:menuitem? elt)) + (error "Illegal content:" elt)) + (string-trim (xml-element-text elt))) + (xml-element-contents elt))) + +(define-xdoc-input 'checkbox + #f ;; special, see canonicalize-xdoc-input-value + (lambda (elt) + (receive (value submitter) (current-input-status elt) + (html:input 'class 'xdoc-checkbox-input + 'type 'checkbox + 'name (xdoc-db-id elt) + 'value "true" + 'checked (string=? value "true") + 'disabled (and submitter 'disabled))))) + +(define-xdoc-input 'radio-buttons + identity-procedure + (lambda (elt) + (receive (value submitter) (current-input-status elt) + (let ((id (xdoc-db-id elt))) + (html:table + (xml-attrs 'class 'xdoc-radio-buttons-input) + (html:tr + #f + (map (lambda (item) + (if (not (xd:radio-entry? item)) + (error "Illegal content:" item)) + (let ((value* (find-attribute 'value item #t))) + (list + (html:td #f + (html:input 'type 'radio + 'name id + 'value value* + 'checked (string=? value* value) + 'disabled (and submitter 'disabled))) + (html:th #f (xml-element-contents item))))) + (xml-element-contents elt)))))))) + +(define (xd:radio-button-values elt) + (map (lambda (elt) + (if (not (xd:radio-entry? elt)) + (error "Illegal content:" elt)) + (find-attribute 'value elt #t)) + (xml-element-contents elt))) + +;;;; Outputs + +(define (define-unary-xdoc-output local checkable? expected-value procedure) + (hash-table/put! xdoc-output-definitions local + (vector checkable? + expected-value + (lambda (elt) + (let ((source (unary-xdoc-output-source elt))) + (receive (value submitter) (current-input-status source) + (values (if (string-null? value) + "unspecified" + (procedure elt value source)) + submitter)))))) + (define-html-generator local (lambda (elt) elt '()))) + +(define (unary-xdoc-output-source elt) + (or (idref-attribute 'source elt #f) + (find-child (nearest-container elt) #t xdoc-input?))) + +(define (define-n-ary-xdoc-output local checkable? expected-value procedure) + (hash-table/put! xdoc-output-definitions local + (vector checkable? + expected-value + (lambda (elt) + (let ((sources + (map named-element (ids-attribute 'sources elt #t)))) + (if (not (pair? sources)) + (error "Multiple-input test needs at least one input.")) + (receive (vals submitter) (current-inputs-status sources) + (values (if (there-exists? vals string-null?) + "unspecified" + (procedure elt vals sources)) + submitter)))))) + (define-html-generator local (lambda (elt) elt '()))) + +(define (define-0-ary-xdoc-output local checkable? expected-value procedure) + (hash-table/put! xdoc-output-definitions local + (vector checkable? + expected-value + procedure)) + (define-html-generator local (lambda (elt) elt '()))) + +(define (xdoc-output-checkable? elt) + (and (vector-ref (%xdoc-output-definition elt) 0) + (let ((b (boolean-attribute 'checkable elt #f))) + (if b + (eq? b 'true) + #t)))) + +(define (xdoc-output-expected-value elt) + ((vector-ref (%xdoc-output-definition elt) 1) elt)) + +(define (xdoc-active-output-status elt) + (receive (correctness submitter) + ((vector-ref (%xdoc-output-definition elt) 2) elt) + (if (not (string? correctness)) + (error "Illegal result from output procedure:" correctness)) + (values correctness submitter))) + +(define (%xdoc-output-definition elt) + (or (hash-table/get xdoc-output-definitions (xdoc-element-name elt) #f) + (error:bad-range-argument elt 'xdoc-output-definition))) + +(define xdoc-output-definitions + (make-eq-hash-table)) + +(define-unary-xdoc-output 'check-input #t + (lambda (elt) + (find-attribute 'expected elt #f)) + (lambda (elt value source) + ((procedure-attribute 'name elt #t) elt value source))) + +(define-n-ary-xdoc-output 'check-inputs #t + (lambda (elt) + (find-attribute 'expected elt #f)) + (lambda (elt vals sources) + ((procedure-attribute 'name elt #t) elt vals sources))) + +(define-0-ary-xdoc-output 'programmed-output #t + (lambda (elt) + (find-attribute 'expected elt #f)) + (lambda (elt) + ((procedure-attribute 'name elt #t) elt + (xdoc-db-id (nearest-container elt))))) + +(define-unary-xdoc-output 'number #t + (lambda (elt) + (complex-attribute 'expected elt #t)) + (lambda (elt value source) + source + (let ((expected (complex-attribute 'expected elt #t)) + (tolerance (or (complex-attribute 'tolerance elt #f) 0)) + (z (string->number value))) + (if z + (if (close-enough? z expected tolerance) + "correct" + "incorrect") + "malformed")))) + +(define (close-enough? z expected tolerance) + (cond ((= tolerance 0) + (= z expected)) + ((= expected 0) + (<= (magnitude (- z expected)) + (magnitude tolerance))) + (else + (<= (magnitude (- z expected)) + (magnitude (* tolerance expected)))))) + +(define-unary-xdoc-output 'boolean #f + (lambda (elt) + (boolean-attribute 'expected elt #t)) + (lambda (elt value source) + source + (let ((expected (boolean-attribute 'expected elt #t))) + (if (or (string=? value "true") (string=? value "false")) + (if (string=? value (symbol-name expected)) + "correct" + "incorrect") + "malformed")))) + +(let ((get-vals + (lambda (source) + (cond ((xd:menu? source) (xd:menu-values source)) + ((xd:radio-buttons? source) (xd:radio-button-values source)) + (else (error "Illegal source:" source))))) + (get-expected + (lambda (elt vals) + (list-ref vals + (- (index1-attribute 'expected (length vals) elt #t) + 1))))) + (define-unary-xdoc-output 'menuindex #f + (lambda (elt) + (get-expected elt (get-vals (unary-xdoc-output-source elt)))) + (lambda (elt value source) + (let ((vals (get-vals source))) + (if (member value vals) + (if (string=? value (get-expected elt vals)) + "correct" + "incorrect") + "malformed"))))) + +;;;; Content selectors + +(define-html-generator 'explain + (lambda (elt) + (if (descendant-outputs-submitted? (content-selector-source elt)) + (switched-content-selector elt "explanation") + '()))) + +(define-html-generator 'hint + (lambda (elt) + (if (descendant-outputs-submitted? (content-selector-source elt)) + '() + (switched-content-selector elt "hint")))) + +(define (switched-content-selector elt noun) + (let* ((type (xdoc-element-name elt)) + (name (symbol type '- (xdoc-db-id elt))) + (value (db-get-persistent-value name #f))) + (if (if (eq? value 'shown) + (not (http-request-post-parameter name)) + (http-request-post-parameter name)) + (let ((text + (list + "\n" + (html:blockquote + (xdoc-attributes elt 'class (symbol 'xdoc- type '-blockquote)) + (xml-element-contents elt)) + "\n")) + (button + (html:input 'type 'submit + 'name name + 'value (string-append "Hide " noun)))) + (if (not (eq? value 'shown)) + (db-set-persistent-value! name 'shown)) + (if (xd:answer? (nearest-container elt)) + (begin + (append-to-answer-block text) + button) + (list button text))) + (begin + (if (not (eq? value 'hidden)) + (db-set-persistent-value! name 'hidden)) + (html:input 'type 'submit + 'name name + 'value (string-append "Show " noun)))))) + +(define-html-generator 'expected-value + (lambda (elt) + (let ((source + (let ((source (content-selector-source elt))) + (let ((outputs (descendant-outputs source))) + (if (not (and (pair? outputs) (null? (cdr outputs)))) + (error "Single source output required:" outputs)) + (car outputs))))) + (and (output-submitted? source) + (html:div (xdoc-attributes elt) + (xdoc-output-expected-value source)))))) + +(define-html-generator 'when + (lambda (elt) + (and ((let ((condition (symbol-attribute 'condition elt #t))) + (or (hash-table/get when-conditions condition #f) + (error "Unknown condition:" condition))) + (content-selector-source elt)) + (html:div (xdoc-attributes elt) + (map (lambda (item) + (generate-item item (lambda (elt) elt #f))) + (xml-element-contents elt)))))) + +(define (define-when-condition name procedure) + (hash-table/put! when-conditions name procedure)) + +(define when-conditions + (make-eq-hash-table)) + +(define-when-condition 'submitted + (lambda (elt) + (descendant-outputs-submitted? elt))) + +(define-when-condition 'not-submitted + (lambda (elt) + (not (descendant-outputs-submitted? elt)))) + +(define-when-condition 'confirming-submission + (lambda (elt) + (confirming-submission? elt))) + +(define (descendant-outputs-submitted? elt) + (let ((outputs (descendant-outputs elt))) + (and (pair? outputs) + (for-all? outputs output-submitted?)))) + +(define (confirming-submission? elt) + (there-exists? (descendant-outputs elt) + (lambda (elt) + (receive (request submitter) (xdoc-active-element-request elt) + submitter + (eq? request 'confirm))))) + +(define (descendant-outputs elt) + (matching-descendants-or-self elt xdoc-output?)) + +(define (xdoc-outputs-submitted? elt) + (let ((outputs (descendant-outputs elt))) + (and (pair? outputs) + (for-all? outputs + (lambda (elt) + (let ((id (xdoc-db-id elt))) + (receive (correctness submitter) + (db-previously-saved-output id) + correctness + submitter))))))) + +(define-html-generator 'case + (lambda (elt) + (let ((children (xml-element-contents elt))) + (let ((token + (let ((source + (let ((source (car children))) + (if (xd:refer? source) + (idref-attribute 'source source #t) + source)))) + (if (not (xdoc-output? source)) + (error "First child of must be output:" source)) + (receive (correctness submitter) (current-output-status source) + (if (or submitter (xdoc-output-checkable? source)) + correctness + "not-checkable"))))) + (let loop ((choices (cdr children))) + (if (pair? choices) + (let ((choice (car choices))) + (if (cond ((xd:choice? choice) + (there-exists? + (attribute-value->list + (find-attribute 'values choice #t)) + (lambda (token*) + (string=? token* token)))) + ((xd:default? choice) + (if (not (null? (cdr choices))) + (error " must be last child:" + choices)) + #t) + (else + (error "Illegal child:" choice))) + (xml-element-contents choice) + (loop (cdr choices)))) + '())))))) + +(define (content-selector-source elt) + (let ((source (idref-attribute 'source elt #f))) + (if source + (begin + (if (not (or (xdoc-container? source) (xdoc-output? source))) + (error "Source must be container or output:" source)) + source) + (nearest-container elt)))) + +;;;; Actions + +(define-html-generator 'submit + (lambda (elt) + (let ((prefix (symbol-attribute 'type elt #t)) + (label (find-attribute 'label elt #t)) + (container + (let ((container (idref-attribute 'scope elt #f))) + (if container + (begin + (if (not (xdoc-container? container)) + (error "scope attribute must refer to container:" + container)) + container) + (nearest-container elt))))) + (let ((inputs (descendant-inputs container))) + (if (for-all? inputs input-submitted?) + #f + (html:input + (xdoc-attributes + elt + 'class (list 'xdoc-submission-action + (symbol 'xdoc- prefix '-action)) + 'type 'submit + 'name (symbol prefix '- (xdoc-db-id container)) + 'value label))))))) + +(define (descendant-inputs elt) + (matching-descendants-or-self elt xdoc-input?)) + +;;;; Attribute accessors + +(define (find-attribute name elt error?) + (let ((attr (%find-attribute name (xml-element-attributes elt)))) + (if attr + (xml-attribute-value attr) + (begin + (if error? + (error "Missing required XDOC attribute:" name elt)) + #f)))) + +(define (%find-attribute name attrs) + (find-matching-item attrs + (lambda (attr) + (xml-name=? (xml-attribute-name attr) name)))) + +(define (symbol-attribute name elt error?) + (let ((string (find-attribute name elt error?))) + (and string + (string->symbol string)))) + +(define (id-attribute name elt error?) + (let ((string (find-attribute name elt error?))) + (and string + (make-xml-qname string)))) + +(define (idref-attribute name elt error?) + (let ((id (id-attribute name elt error?))) + (and id + (named-element id)))) + +(define (ids-attribute name elt error?) + (let ((string (find-attribute name elt error?))) + (and string + (map make-xml-qname (attribute-value->list string))))) + +(define (nmtokens-attribute name elt error?) + (let ((string (find-attribute name elt error?))) + (and string + (map make-xml-nmtoken (attribute-value->list string))))) + +(define (attribute-value->list names) + (burst-string names char-set:whitespace #t)) + +(define (boolean-attribute name elt error?) + (let ((value (symbol-attribute name elt error?))) + (if (and value (not (memq value '(true false)))) + (error "Ill-formed boolean attribute:" value)) + value)) + +(define (numeric-attribute name predicate elt error?) + (let ((string (find-attribute name elt error?))) + (and string + (let ((z (string->number string))) + (if (not (and z (predicate z))) + (error "Ill-formed number:" z)) + z)))) + +(define (int0-attribute name elt error?) + (numeric-attribute name exact-nonnegative-integer? elt error?)) + +(define (int1-attribute name elt error?) + (numeric-attribute name exact-positive-integer? elt error?)) + +(define (complex-attribute name elt error?) + (numeric-attribute name complex? elt error?)) + +(define (index0-attribute name limit elt error?) + (numeric-attribute name + (lambda (z) + (and (exact-nonnegative-integer? z) + (< z limit))) + elt + error?)) + +(define (index1-attribute name limit elt error?) + (numeric-attribute name + (lambda (z) + (and (exact-positive-integer? z) + (<= z limit))) + elt + error?)) + +(define (procedure-attribute name elt error?) + (let ((name (procedure-name-attribute name elt error?))) + (and name + (environment-lookup *xdoc-environment* name)))) + +(define (procedure-name-attribute name elt error?) + (let ((symbol (symbol-attribute name elt error?))) + (if (not (or (not symbol) (xdoc-procedure-name? symbol))) + (error "Malformed procedure attribute:" symbol)) + symbol)) + +(define (xdoc-procedure-name? symbol) + (re-string-match "[A-Za-z_][0-9A-Za-z_]*" (symbol-name symbol))) + +;;;; Merging of attributes + +(define (xdoc-attributes elt . keyword-list) + (merge-attributes (apply xml-attrs keyword-list) + (preserved-attributes elt))) + +(define (preserved-attributes elt) + (keep-matching-items (xml-element-attributes elt) preserved-attribute?)) + +(define (merge-attributes attrs defaults) + (map* (delete-matching-items defaults + (lambda (attr) + (%find-attribute (xml-attribute-name attr) attrs))) + (lambda (attr) + (let ((attr* + (and (merged-attribute? attr) + (%find-attribute (xml-attribute-name attr) defaults)))) + (if attr* + (merge-attribute attr attr*) + attr))) + attrs)) + +(define (preserved-attribute? attr) + (let ((name (xml-attribute-name attr))) + (or (xml-name=? name 'class) + (xml-name=? name 'style) + (and (xml-name-prefix=? name 'xmlns) + (not (string=? (xml-attribute-value attr) + (xml-namespace-iri-string xdoc-iri))))))) + +(define (merged-attribute? attr) + (let ((name (xml-attribute-name attr))) + (xml-name=? name 'class))) + +(define (merge-attribute attr1 attr2) + (let ((name (xml-attribute-name attr1))) + (cond ((xml-name=? name 'class) + (make-xml-attribute name + (class-union (xml-attribute-value attr1) + (xml-attribute-value attr2)))) + (else + (error:bad-range-argument attr1 'MERGE-ATTRIBUTE))))) + +(define (class-union c1 c2) + (let ((classes + (let ((c2 (attribute-value->list c2))) + (let loop ((c1 (attribute-value->list c1))) + (if (pair? c1) + (if (member (car c1) c2) + (loop (cdr c1)) + (cons (car c1) (loop (cdr c1)))) + c2))))) + (if (pair? classes) + (call-with-output-string + (lambda (port) + (write-string (car classes) port) + (for-each (lambda (class) + (write-char #\space port) + (write-string class port)) + (cdr classes)))) + ""))) + +;;;; Element accessors + +(define (find-named-child local elt error?) + (find-child elt error? + (lambda (child) + (xdoc-element-name=? child local)))) + +(define (find-child elt error? predicate) + (%find-result (%find-child elt predicate) error?)) + +(define (%find-child elt predicate) + (find-matching-item (xml-element-contents elt) + (lambda (item) + (and (xml-element? item) + (predicate item))))) + +(define (%find-result elt error?) + (if (and (not elt) error?) + (error "Unable to find matching element.")) + elt) + +(define (xml-element-text elt) + (let loop ((items (xml-element-contents elt)) (text "")) + (if (pair? items) + (begin + (if (not (string? (car items))) + (error "Illegal text component:" (car items))) + (loop (cdr items) + (string-append text (car items)))) + text))) + +(define (find-named-descendant local elt error?) + (find-descendant elt error? + (lambda (elt) + (xdoc-element-name=? elt local)))) + +(define (find-descendant elt error? predicate) + (%find-result (%find-descendant elt predicate) error?)) + +(define (find-descendant-or-self elt error? predicate) + (%find-result (%find-descendant-or-self elt predicate) error?)) + +(define (matching-descendants elt predicate) + (reverse! (%matching-descendants elt predicate '()))) + +(define (matching-descendants-or-self elt predicate) + (reverse! (%matching-descendants-or-self elt predicate '()))) + +(define (%find-descendant elt predicate) + (let loop ((items (xml-element-contents elt))) + (and (pair? items) + (or (and (xml-element? (car items)) + (%find-descendant-or-self (car items) predicate)) + (loop (cdr items)))))) + +(define (%find-descendant-or-self elt predicate) + (if (predicate elt) + elt + (%find-descendant elt predicate))) + +(define (%matching-descendants elt predicate matches) + (let loop ((items (xml-element-contents elt)) (matches matches)) + (if (pair? items) + (loop (cdr items) + (let ((item (car items))) + (if (xml-element? item) + (%matching-descendants-or-self item predicate matches) + matches))) + matches))) + +(define (%matching-descendants-or-self elt predicate matches) + (%matching-descendants elt + predicate + (if (predicate elt) + (cons elt matches) + matches))) + +;;;; XDOC element data types + +(define xdoc-iri + (make-xml-namespace-iri "http://mit.edu/2003/XDOC")) + +(define (xdoc-name? name) + (xml-name-iri=? name xdoc-iri)) + +(define (xdoc-name=? name local) + (and (xdoc-name? name) + (xml-name-local=? name local))) + +(define (xdoc-element? item) + (and (xml-element? item) + (xdoc-name? (xml-element-name item)))) + +(define (xdoc-element-name item) + (and (xml-element? item) + (let ((name (xml-element-name item))) + (and (xdoc-name? name) + (xml-name-local name))))) + +(define (xdoc-element-name=? item local) + (and (xml-element? item) + (xdoc-name=? (xml-element-name item) local))) + +(define (xdoc-content-type elt) + (let ((local (xdoc-element-name elt))) + (and local + (or (hash-table/get xdoc-content-types local #f) + (error "Unknown XDOC element name:" local))))) + +(define xdoc-content-types + (make-eq-hash-table)) + +(define (xdoc-element-type elt) + (let ((local (xdoc-element-name elt))) + (and local + (or (hash-table/get xdoc-element-types local #f) + (error "Unknown XDOC element name:" local))))) + +(define xdoc-element-types + (make-eq-hash-table)) + +(define (xdoc-container? elt) + (let ((type (xdoc-element-type elt))) + (or (eq? type 'top-level-container) + (eq? type 'internal-container)))) + +(define (xdoc-internal-container? elt) + (eq? (xdoc-element-type elt) 'internal-container)) + +(define (xdoc-input? elt) + (eq? (xdoc-element-type elt) 'input)) + +(define (xdoc-output? elt) + (eq? (xdoc-element-type elt) 'output)) + +(define (xdoc-content-selector? elt) + (eq? (xdoc-element-type elt) 'content-selector)) + +(define (xdoc-action? elt) + (eq? (xdoc-element-type elt) 'action)) + +(define-syntax define-element + (sc-macro-transformer + (lambda (form env) + env + (let ((local (cadr form)) + (content-type (caddr form)) + (elt-type (cadddr form))) + (let ((qname (symbol-append 'xd: local))) + `(BEGIN + (DEFINE ,qname + (STANDARD-XML-ELEMENT-CONSTRUCTOR ',qname XDOC-IRI + ,(eq? content-type 'empty))) + (DEFINE ,(symbol-append qname '?) + (LET ((NAME (MAKE-XML-NAME ',qname XDOC-IRI))) + (LAMBDA (OBJECT) + (AND (XML-ELEMENT? OBJECT) + (XML-NAME=? (XML-ELEMENT-NAME OBJECT) NAME))))) + (HASH-TABLE/PUT! XDOC-CONTENT-TYPES ',local ',content-type) + (HASH-TABLE/PUT! XDOC-ELEMENT-TYPES ',local ',elt-type))))))) + +(define-element xdoc mixed top-level-container) +(define-element head mixed internal) +(define-element page-frame mixed internal) +(define-element due-date empty internal) +(define-element problem mixed internal-container) +(define-element answer element internal-container) +(define-element label mixed internal) + +(define-element text empty input) +(define-element menu element input) +(define-element menuitem text internal) +(define-element checkbox empty input) +(define-element radio-buttons element input) +(define-element radio-entry mixed internal) + +(define-element check-input empty output) +(define-element check-inputs empty output) +(define-element programmed-output empty output) +(define-element number empty output) +(define-element boolean empty output) +(define-element menuindex empty output) + +(define-element explain mixed content-selector) +(define-element hint mixed content-selector) +(define-element expected-value empty content-selector) +(define-element when mixed content-selector) +(define-element case element content-selector) +(define-element refer empty internal) +(define-element choice mixed internal) +(define-element default mixed internal) + +(define-element submit empty action) + +(define (xd:true-false . keyword-list) + (xd:radio-buttons (apply xml-attrs keyword-list) + (xd:radio-entry (xml-attrs 'value 'true) "True") + (xd:radio-entry (xml-attrs 'value 'false) "False"))) + +(define (xd:true-false? object) + (and (xd:radio-buttons? object) + (let ((entries (xml-element-contents object))) + (and (fix:= (length entries) 2) + (let ((v1 (find-attribute 'value (car entries) #t)) + (v2 (find-attribute 'value (cadr entries) #t))) + (or (and (string=? v1 "true") (string=? v2 "false")) + (and (string=? v1 "false") (string=? v2 "true")))))))) \ No newline at end of file