From: Chris Hanson Date: Mon, 1 Nov 2004 19:09:25 +0000 (+0000) Subject: Remove xdoc code. X-Git-Tag: 20090517-FFI~1489 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8b4e16fc9783288d53c1936050a488d54a379728;p=mit-scheme.git Remove xdoc code. --- diff --git a/v7/src/ssp/Makefile.in b/v7/src/ssp/Makefile.in index c474eae3d..7bc76765a 100644 --- a/v7/src/ssp/Makefile.in +++ b/v7/src/ssp/Makefile.in @@ -1,4 +1,4 @@ -# $Id: Makefile.in,v 1.1 2004/10/29 05:32:18 cph Exp $ +# $Id: Makefile.in,v 1.2 2004/11/01 19:09:24 cph Exp $ # # Copyright 2004 Massachusetts Institute of Technology # @@ -68,5 +68,6 @@ install: $(INSTALL_DATA) *.com $(DESTDIR)$(SSP_DIR)/. $(INSTALL_DATA) *.bci $(DESTDIR)$(SSP_DIR)/. $(INSTALL_DATA) ssp-unx.pkd $(DESTDIR)$(SSP_DIR)/. + $(INSTALL_DATA) $(srcdir)/load.scm $(DESTDIR)$(SSP_DIR)/. .PHONY: install diff --git a/v7/src/ssp/compile.scm b/v7/src/ssp/compile.scm index fa5d8eae3..6b989d673 100644 --- a/v7/src/ssp/compile.scm +++ b/v7/src/ssp/compile.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: compile.scm,v 1.3 2004/10/27 20:03:43 cph Exp $ +$Id: compile.scm,v 1.4 2004/11/01 19:09:24 cph Exp $ Copyright 2003 Massachusetts Institute of Technology @@ -35,4 +35,5 @@ USA. "xdoc" "xhtml-expander" "xmlrpc")) - (cref/generate-constructors "ssp"))) \ No newline at end of file + (cref/generate-constructors "ssp") + (cref/generate-constructors "xdoc"))) \ No newline at end of file diff --git a/v7/src/ssp/db.scm b/v7/src/ssp/db.scm deleted file mode 100644 index 377c68b1b..000000000 --- a/v7/src/ssp/db.scm +++ /dev/null @@ -1,739 +0,0 @@ -#| -*-Scheme-*- - -$Id: db.scm,v 1.4 2004/10/28 19:54:54 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/ssp/load.scm b/v7/src/ssp/load.scm index 358b0d2a1..8e2680601 100644 --- a/v7/src/ssp/load.scm +++ b/v7/src/ssp/load.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: load.scm,v 1.3 2004/10/27 20:04:01 cph Exp $ +$Id: load.scm,v 1.4 2004/11/01 19:09:24 cph Exp $ Copyright 2003,2004 Massachusetts Institute of Technology @@ -25,10 +25,10 @@ USA. ;;;; SSP/XDOC loader -(load-option 'XML) -(load-option 'POSTGRESQL) -(load-option 'MIME-CODEC) +(load-option 'xml) +(load-option 'postgresql) +(load-option 'mime-codec) (with-working-directory-pathname (directory-pathname (current-load-pathname)) (lambda () - (package/system-loader "ssp" '() 'QUERY))) -(add-subsystem-identification! "SSP/XDOC" '(0 3)) \ No newline at end of file + (package/system-loader "ssp" '() 'query))) +(add-subsystem-identification! "SSP" '(0 3)) \ No newline at end of file diff --git a/v7/src/ssp/ssp.pkg b/v7/src/ssp/ssp.pkg index 585f21784..457481058 100644 --- a/v7/src/ssp/ssp.pkg +++ b/v7/src/ssp/ssp.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: ssp.pkg,v 1.11 2004/11/01 04:56:58 cph Exp $ +$Id: ssp.pkg,v 1.12 2004/11/01 19:09:24 cph Exp $ Copyright 2003,2004 Massachusetts Institute of Technology @@ -109,191 +109,6 @@ USA. define-sabbr get-sabbr)) -(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?)) - (define-package (runtime ssp xml-rpc) (files "xmlrpc") (parent (runtime ssp)) diff --git a/v7/src/ssp/validate-xdoc.scm b/v7/src/ssp/validate-xdoc.scm deleted file mode 100644 index c1e3172f8..000000000 --- a/v7/src/ssp/validate-xdoc.scm +++ /dev/null @@ -1,461 +0,0 @@ -#| -*-Scheme-*- - -$Id: validate-xdoc.scm,v 1.1 2003/12/29 05:24:47 uid67408 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/ssp/xdoc.scm b/v7/src/ssp/xdoc.scm deleted file mode 100644 index 9201f5747..000000000 --- a/v7/src/ssp/xdoc.scm +++ /dev/null @@ -1,1534 +0,0 @@ -#| -*-Scheme-*- - -$Id: xdoc.scm,v 1.5 2004/10/30 01:20:40 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