--- /dev/null
+#| -*-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))
+\f
+(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))))))
+\f
+(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"))
+\f
+;;;; 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")
+ ")"))
+\f
+(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?)))
+\f
+(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))))
+\f
+;;;; 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)))
+\f
+;;;; 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)))))
+\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*")
+\f
+(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)))
+\f
+;;;; 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)))
+\f
+;;;; 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)))
+\f
+(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)))
+\f
+(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
--- /dev/null
+#| -*-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)))
+\f
+(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 <xdoc>."))
+ (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))
+\f
+;;;; 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)))
+\f
+;;;; 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)))
+\f
+;;;; 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)))
+\f
+;;;; 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)
+\f
+;;;; 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)))
+\f
+;;;; 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)))))
+\f
+(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?))
+\f
+(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
--- /dev/null
+#| -*-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))
+\f
+(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\""))
+\f
+(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))))
+\f
+;;;; 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)))))))))))
+\f
+(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)))
+\f
+;;;; 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)))
+\f
+;;;; HTML generator
+
+(define (generate-xdoc-html root)
+ (if (not (xd:xdoc? root))
+ (error "Top level element must be <xd:xdoc>:" 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))))))
+\f
+(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 '() '())))
+\f
+;;;; 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)))
+\f
+(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)))
+\f
+(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 <xd:problem> container:" local))))))
+ 'true))
+\f
+(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 <xd:answer> 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)))
+\f
+;;;; 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))))))
+\f
+(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 <xd:menu> 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 <xd:radio-buttons> 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 <xd:radio-buttons> content:" elt))
+ (find-attribute 'value elt #t))
+ (xml-element-contents elt)))
+\f
+;;;; 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))
+\f
+(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 <xd:menuindex> 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")))))
+\f
+;;;; 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))))))
+\f
+(define-html-generator 'when
+ (lambda (elt)
+ (and ((let ((condition (symbol-attribute 'condition elt #t)))
+ (or (hash-table/get when-conditions condition #f)
+ (error "Unknown <xd:when> 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)))))))
+\f
+(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 <xd:case> 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 "<xd:default> must be last child:"
+ choices))
+ #t)
+ (else
+ (error "Illegal <xd:case> 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))))
+\f
+;;;; 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?))
+\f
+;;;; 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))
+\f
+(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)))
+\f
+;;;; 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))))
+ "")))
+\f
+;;;; 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)))
+\f
+;;;; 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))
+\f
+(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
projects / mit-scheme.git / commitdiff