--- /dev/null
+#| -*-Scheme-*-
+
+$Id: compile.scm,v 1.1 2003/12/29 05:24:29 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/mod-lisp compilation
+
+(with-working-directory-pathname (directory-pathname (current-load-pathname))
+ (lambda ()
+ (compile-file "xhtml-expander")
+ (compile-file "xhtml")
+ (compile-file "db")
+ (compile-file "mod-lisp")
+ (compile-file "matcher")
+ (compile-file "xdoc")
+ (compile-file "xmlrpc")))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: db.scm,v 1.1 2003/12/29 05:24:32 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.
+
+|#
+
+;;;; 6.002ex database support
+
+(declare (usual-integrations))
+\f
+(define db-name "six002x_spring04")
+(define pgsql-conn #f)
+(define *database-connection* #f)
+(define *user-name*)
+(define *ps-number*)
+(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 (string-append "dbname=" db-name))))
+ (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-key* page-key))
+ (thunk)))
+ (fluid-let ((*database-connection* pgsql-conn)
+ (*user-name* (http-request-user-name))
+ (*ps-number* ps-number)
+ (*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 "dbname=six002x")))
+ (set! pgsql-conn conn)
+ (set! *database-connection* conn)
+ conn))))
+
+(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-expander 'db-run-query
+ (lambda strings
+ (exec-pgsql-query (database-connection)
+ (string-append (apply string-append strings) ";"))))
+
+(define-expander 'db-run-cmd
+ (lambda strings
+ (let ((result (apply db-run-query strings)))
+ (let ((status (pgsql-cmd-status result)))
+ (pgsql-clear result)
+ status))))
+
+(define-expander 'db-quote
+ (lambda (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-expander 'db-register-problem-set
+ (lambda (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)))
+ (loop item))))
+ (xml-element-contents elt)))
+ n-outputs)))))
+
+(define (register-output ps-number name part)
+ (db-run-cmd "INSERT INTO registered_outputs VALUES"
+ " (" (db-quote ps-number)
+ ", " (db-quote name)
+ ", " (db-quote part)
+ ")"))
+\f
+(define-expander 'db-registered-problem-sets
+ (lambda ()
+ (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-expander 'db-ps-problem-names
+ (lambda (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-expander 'db-problem-submitted?
+ (lambda (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-expander 'db-get-ps-structure
+ (lambda ()
+ (let ((result
+ (db-run-query "SELECT ps_number, ps_part, name"
+ " FROM registered_outputs"
+ " 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)
+ ")"))
+ ((not-submitted)
+ (db-run-cmd "UPDATE saved_inputs SET"
+ " value = " (db-quote value)
+ ", submitter = " (db-quote submitter)
+ " WHERE " (saved-inputs-condition id)))))
+
+(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")
+ ")"))
+ ((not-submitted)
+ (db-run-cmd "UPDATE saved_outputs SET"
+ " correctness = " (db-quote correctness)
+ ", submitter = " (db-quote submitter)
+ ", late_p = " (if late? "TRUE" "FALSE")
+ " 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-expander 'db-get-saved-output
+ (lambda (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-expander 'db-get-persistent-value
+ (lambda (name default)
+ (let ((result
+ (db-run-query (persistent-value-query name '(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-expander 'db-set-persistent-value!
+ (lambda (name object)
+ (let ((value (write-to-string object))
+ (result
+ (db-run-query (persistent-value-query name '(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))))
+ (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-expander 'db-intern-persistent-value!
+ (lambda (name get-object)
+ (let ((result
+ (db-run-query (persistent-value-query name '(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-expander 'db-delete-persistent-value!
+ (lambda (name)
+ (db-run-cmd "DELETE FROM persistent_values WHERE "
+ (persistent-value-condition name))))
+
+(define (persistent-value-query name fields for-update?)
+ (string-append "SELECT " (field-list->db-string fields)
+ " FROM persistent_values"
+ " WHERE " (persistent-value-condition name)
+ (if for-update? " FOR UPDATE" "")))
+
+(define (persistent-value-condition name)
+ (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-expander 'db-saved-submitters
+ (lambda (user-name)
+ (db-marked-submitters user-name "submitter IS NOT NULL")))
+
+(define-expander 'db-late-submitters
+ (lambda (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)
+ (cons (string-append
+ (pgsql-get-value result i 0)
+ "/"
+ (pgsql-get-value result i 1))
+ names))
+ (begin
+ (pgsql-clear result)
+ (reverse! names)))))))
+
+(define-expander 'db-clear-submitter
+ (lambda (user-name number)
+ (receive (ps-number submitter) (parse-problem-number number)
+ (db-run-cmd "UPDATE saved_inputs"
+ " SET submitter IS 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 IS NULL"))))
+
+(define-expander 'db-clear-late-flag
+ (lambda (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-expander 'db-known-user?
+ (lambda (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-expander 'db-known-users
+ (lambda (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-expander 'db-new-user-account
+ (lambda (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-expander 'db-change-user-password
+ (lambda (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-expander 'db-user-real-name
+ (lambda (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-expander 'db-set-user-real-name
+ (lambda (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-expander 'db-user-enabled?
+ (lambda (user-name)
+ (get-user-flag user-name "enabled_p")))
+
+(define-expander 'db-user-administrator?
+ (lambda (user-name)
+ (get-user-flag user-name "administrator_p")))
+
+(define-expander 'db-set-user-enabled
+ (lambda (user-name value)
+ (set-user-flag user-name "enabled_p" value)))
+
+(define-expander 'db-set-user-administrator
+ (lambda (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-expander 'db-valid-password?
+ (lambda (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-expander 'db-generate-password
+ (lambda ()
+ (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: load.scm,v 1.1 2003/12/29 05:24:36 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/mod-lisp loader
+
+(load-option 'xml)
+(load-option 'postgresql)
+(load-option 'mime-codec)
+(with-working-directory-pathname (directory-pathname (current-load-pathname))
+ (lambda ()
+ (load "xhtml-expander")
+ (load "xhtml")
+ (load "mod-lisp")
+ (load "db")
+ (load "matcher")
+ (load "xdoc")
+ (load "xmlrpc")))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: matcher.scm,v 1.1 2003/12/29 05:24:39 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.
+
+|#
+
+;;;; List matching
+
+(declare (usual-integrations))
+\f
+(define ((ml:matcher pattern) items)
+ (ml:apply pattern items))
+
+(define (ml:apply pattern items)
+ (guarantee-list items 'ML:APPLY)
+ (pattern (lambda (kf p r) kf p (r->v r))
+ (lambda () #f)
+ items))
+
+(define ((ml:match predicate) ks kf p)
+ (if (pair? p)
+ (let ((item (car p)))
+ (if (predicate item)
+ (ks kf (cdr p) (r1 item))
+ (kf)))
+ (kf)))
+
+(define ((ml:noise predicate) ks kf p)
+ (if (and (pair? p) (predicate (car p)))
+ (ks kf (cdr p) (r0))
+ (kf)))
+
+(define (ml:end ks kf p)
+ (if (null? p)
+ (ks kf p (r0))
+ (kf)))
+
+(define ((ml:* matcher) ks kf p)
+ (let ks* ((kf kf) (p p) (r (r0)))
+ (matcher (lambda (kf p r*) (ks* kf p (r+ r r*)))
+ (lambda () (ks kf p r))
+ p)))
+
+(define (ml:seq . matchers)
+ (let loop ((matchers matchers))
+ (if (pair? matchers)
+ (let ((m1 (car matchers))
+ (matchers (cdr matchers)))
+ (if (pair? matchers)
+ (let ((m2 (loop matchers)))
+ (lambda (ks kf p)
+ (m1 (lambda (kf p r1)
+ (m2 (lambda (kf p r2) (ks kf p (r+ r1 r2)))
+ kf
+ p))
+ kf
+ p)))
+ m1))
+ (lambda (ks kf p) (ks kf p (r0))))))
+
+(define (ml:alt . matchers)
+ (if (pair? matchers)
+ (let loop ((matchers matchers))
+ (let ((m1 (car matchers))
+ (matchers (cdr matchers)))
+ (if (pair? matchers)
+ (let ((m2 (loop matchers)))
+ (lambda (ks kf p)
+ (m1 ks
+ (lambda () (m2 ks kf p))
+ p)))
+ m1)))
+ (lambda (ks kf p) ks p (kf))))
+
+(define (ml:transform procedure matcher)
+ (transformer (lambda (v) (v->r (procedure v))) matcher))
+
+(define (ml:encapsulate procedure matcher)
+ (transformer (lambda (v) (r1 (procedure v))) matcher))
+
+(define (ml:map procedure matcher)
+ (transformer (lambda (v) (v->r (vector-map procedure v))) matcher))
+
+(define ((transformer transform matcher) ks kf p)
+ (matcher (lambda (kf p r) (ks kf p (transform (r->v r))))
+ kf
+ p))
+\f
+(define (ml:+ matcher)
+ (ml:seq matcher (ml:* matcher)))
+
+(define (ml:? matcher)
+ (ml:alt matcher (ml:seq)))
+
+(define ((ml:values . items) ks kf p)
+ (ks kf p (l->r items)))
+
+(define (ml:*-list matcher)
+ (ml:encapsulate vector->list (ml:* matcher)))
+
+(define-integrable (r0) '#())
+(define-integrable (r1 item) (vector item))
+(define-integrable (r->v r) r)
+(define-integrable (v->r v) v)
+(define-integrable (l->r l) (list->vector l))
+
+(define (r+ r1 r2)
+ (let ((n1 (vector-length r1))
+ (n2 (vector-length r2)))
+ (cond ((fix:= n1 0) r2)
+ ((fix:= n2 0) r1)
+ (else
+ (let ((r (make-vector (fix:+ n1 n2))))
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i n1))
+ (vector-set! r i (vector-ref r1 i)))
+ (do ((i 0 (fix:+ i 1))
+ (j n1 (fix:+ j 1)))
+ ((fix:= i n2))
+ (vector-set! r j (vector-ref r2 i)))
+ r)))))
+
+#|
+
+;;; If the set of items doesn't include #F or pairs, this should be
+;;; faster than the above.
+
+(define-integrable (r0) #f)
+(define-integrable (r1 item) item)
+
+(define (r+ r1 r2)
+ (cond ((not r1) r2)
+ ((not r2) r1)
+ (else (cons r1 r2))))
+
+(define (r->v r)
+ (if r
+ (let ((n
+ (let loop ((r r))
+ (if (pair? r)
+ (fix:+ (loop (car r))
+ (loop (cdr r)))
+ 1))))
+ (let ((v (make-vector n)))
+ (let loop ((r r) (i 0) (q '()))
+ (if (pair? r)
+ (loop (car r)
+ i
+ (cons (cdr r) q))
+ (begin
+ (vector-set! v i r)
+ (if (pair? q)
+ (loop (car q)
+ (fix:+ i 1)
+ (cdr q))))))
+ v))
+ '#()))
+
+(define (v->r v)
+ ???)
+
+(define (l->r l)
+ ???)
+
+|#
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: mod-lisp.scm,v 1.1 2003/12/29 05:24:43 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.
+
+|#
+
+;;;; MIT/GNU Scheme interface to Apache mod-lisp.
+
+(declare (usual-integrations))
+\f
+(define (start-server)
+ (start-server-internal 3000
+ (host-address-loopback)
+ (cond ((file-directory? "/web/www/") "/web/www/")
+ ((file-directory? "/var/www/") "/var/www/")
+ (else (error "No server root?")))))
+
+(define root-paths
+ '("/projects/scheme-pages/"
+ "/classes/6.002x/spring04/"
+ "/classes/6.002ex/spring04/"))
+
+(define (start-server-internal tcp-port tcp-host server-root)
+ (let ((socket (open-tcp-server-socket tcp-port tcp-host)))
+ (dynamic-wind
+ (lambda () unspecific)
+ (lambda ()
+ (do () ((channel-closed? socket))
+ (let ((port (tcp-server-connection-accept socket #t #f "\n")))
+ (dynamic-wind
+ (lambda () unspecific)
+ (lambda ()
+ (write-response
+ (let ((response
+ (call-with-current-continuation
+ (lambda (k)
+ (bind-condition-handler (list condition-type:error)
+ k
+ (lambda ()
+ (handle-request (read-request port)
+ server-root)))))))
+ (if (condition? response)
+ (status-response 500 (condition->html response))
+ response))
+ port))
+ (lambda () (close-port port))))))
+ (lambda () (channel-close socket)))))
+
+(let ((target (the-environment))
+ (source (->environment '(RUNTIME DEBUGGER))))
+ (for-each (lambda (name)
+ (link-variables target name source name))
+ '(MAKE-INITIAL-DSTATE
+ DSTATE/SUBPROBLEM
+ COMMAND/EARLIER-SUBPROBLEM
+ COMMAND/PRINT-SUBPROBLEM)))
+\f
+(define (condition->html condition)
+ (call-with-output-string
+ (lambda (port)
+ (write-string "<p>" port)
+ (newline port)
+ (escape-output port
+ (lambda (port)
+ (write-condition-report condition port)))
+ (newline port)
+ (write-string "</p>" port)
+ (newline port)
+ (newline port)
+ (write-string "<pre>" port)
+ (let ((dstate (make-initial-dstate condition)))
+ (command/print-subproblem dstate port)
+ (let loop ()
+ (if (let ((next
+ (stack-frame/next-subproblem (dstate/subproblem dstate))))
+ (and next (not (stack-frame/repl-eval-boundary? next))))
+ (begin
+ (newline port)
+ (newline port)
+ (escape-output port
+ (lambda (port)
+ (command/earlier-subproblem dstate port)))
+ (loop)))))
+ (write-string "</pre>" port)
+ (newline port))))
+
+(define (escape-output port generator)
+ (write-escaped-string (call-with-output-string generator) port))
+
+(define (write-escaped-string string port)
+ (let ((end (string-length string)))
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i end))
+ (write-escaped-char (string-ref string i) port))))
+
+(define (write-escaped-char char port)
+ (case char
+ ((#\<) (write-string "<" port))
+ ((#\&) (write-string "&" port))
+ (else (write-char char port))))
+\f
+;;;; Request handler
+
+(define (handle-request request server-root)
+ (let ((url (http-message-url request)))
+ (if trace-requests?
+ (write-line
+ `(HANDLE-REQUEST ,(http-message-method request)
+ ,url
+ ,@(http-message-url-parameters request))))
+ (receive (root-dir relative) (url->relative url server-root)
+ (fluid-let ((*root-dir* root-dir))
+ (let ((response (make-http-message)))
+ (let ((expand
+ (lambda (pathname default-type handler)
+ (add-status-header response 200)
+ (add-content-type-header response default-type)
+ (set-entity response
+ (if handler
+ (mod-lisp-expander request
+ response
+ pathname
+ handler)
+ (->pathname pathname))))))
+ (receive (default-type handler) (get-subtree-handler relative)
+ (let ((pathname (merge-pathnames relative root-dir)))
+ (if handler
+ (expand pathname default-type handler)
+ (begin
+ (maybe-parse-post-variables request)
+ (handle-request:default request
+ response
+ pathname
+ expand))))))
+ response)))))
+
+(define (url->relative url server-root)
+ (let loop ((root-paths root-paths))
+ (if (not (pair? root-paths))
+ (error "Unknown URL root:" url))
+ (let ((prefix (->namestring (pathname-as-directory (car root-paths)))))
+ (if (string-prefix? prefix url)
+ (values (merge-pathnames (enough-pathname prefix "/")
+ (pathname-as-directory server-root))
+ (string-tail url (string-length prefix)))
+ (loop (cdr root-paths))))))
+
+(define *root-dir*)
+(define trace-requests? #f)
+
+(define (handle-request:default request response pathname expand)
+ (let ((page-found
+ (lambda (pathname)
+ (let ((type (file-content-type pathname)))
+ (expand pathname type (get-mime-handler type)))))
+ (page-not-found
+ (lambda ()
+ (status-response! response 404 (http-message-url request)))))
+ (case (file-type-indirect pathname)
+ ((REGULAR)
+ (page-found pathname))
+ ((DIRECTORY)
+ (let ((pathname (find-index-page pathname)))
+ (if pathname
+ (page-found pathname)
+ (page-not-found))))
+ (else
+ (page-not-found)))))
+\f
+(define (get-subtree-handler relative)
+ (let ((entry
+ (find-matching-item subtree-handlers
+ (lambda (entry)
+ (let loop
+ ((d1 (pathname-directory (vector-ref entry 0)))
+ (d2 (pathname-directory relative)))
+ (or (not (pair? d1))
+ (and (pair? d2)
+ (equal? (car d1) (car d2))
+ (loop (cdr d1) (cdr d2)))))))))
+ (if entry
+ (values (vector-ref entry 1) (vector-ref entry 2))
+ (values #f #f))))
+
+(define (define-subtree-handler pathname default-type handler)
+ (let ((pathname (pathname-as-directory pathname)))
+ (let ((entry
+ (find-matching-item subtree-handlers
+ (lambda (entry)
+ (pathname=? (vector-ref entry 0) pathname)))))
+ (if entry
+ (begin
+ (vector-set! entry 1 default-type)
+ (vector-set! entry 2 handler))
+ (begin
+ (set! subtree-handlers
+ (cons (vector pathname default-type handler)
+ subtree-handlers))
+ unspecific)))))
+
+(define subtree-handlers '())
+
+(define (find-index-page directory)
+ (let ((directory (pathname-as-directory directory)))
+ (let ((filename
+ (find-matching-item default-index-pages
+ (lambda (filename)
+ (file-exists? (merge-pathnames filename directory))))))
+ (and filename
+ (merge-pathnames filename directory)))))
+
+(define default-index-pages
+ '("index.xhtml" "index.xml" "index.html"))
+
+(define (mod-lisp-expander request response pathname expander)
+ (call-with-output-string
+ (lambda (port)
+ (fluid-let ((*current-request* request)
+ (*current-response* response)
+ (*current-pathname* pathname)
+ (expander-eval
+ (lambda (expression environment)
+ (with-repl-eval-boundary (nearest-repl)
+ (lambda ()
+ (eval expression environment))))))
+ (expander pathname port)))))
+
+(define *current-request*)
+(define *current-response*)
+(define *current-pathname*)
+\f
+;;;; MIME stuff
+
+(define (file-content-type pathname)
+ (let ((extension (pathname-type pathname)))
+ (and (string? extension)
+ (hash-table/get mime-extensions extension #f))))
+
+(define (get-mime-handler type)
+ (hash-table/get mime-handlers type #f))
+
+(define (define-mime-handler type handle-request)
+ (cond ((symbol? type)
+ (hash-table/put! mime-handlers type handle-request))
+ ((and (pair? type)
+ (symbol? (car type))
+ (for-all? (cdr type) string?))
+ (hash-table/put! mime-handlers (car type) handle-request)
+ (for-each (lambda (extension)
+ (let ((index
+ (->namestring
+ (pathname-new-type "index" extension))))
+ (if (not (member index default-index-pages))
+ (set! default-index-pages
+ (append default-index-pages
+ (list index)))))
+ (hash-table/put! mime-extensions extension (car type)))
+ (cdr type)))
+ (else
+ (error:wrong-type-argument type "MIME type" 'DEFINE-MIME-HANDLER))))
+
+(define mime-handlers (make-eq-hash-table))
+(define mime-extensions (make-string-hash-table))
+
+(define (initialize-mime-extensions)
+ (for-each-file-line "/etc/mime.types"
+ (lambda (line)
+ (let ((line (string-trim line)))
+ (if (and (fix:> (string-length line) 0)
+ (not (char=? (string-ref line 0) #\#)))
+ (let ((tokens (burst-string line char-set:whitespace #t)))
+ (let ((type (string->symbol (car tokens))))
+ (for-each (lambda (token)
+ (hash-table/put! mime-extensions token type))
+ (cdr tokens))))))))
+ ;; Should be 'application/xhtml+xml -- IE loses.
+ (define-mime-handler '(text/html "xhtml" "xht")
+ (lambda (pathname port)
+ (expand-xhtml-file pathname port))))
+\f
+;;;; Read request
+
+(define (read-request port)
+ (let ((request (make-http-message)))
+ (let loop ()
+ (let ((keyword (read-line port)))
+ (if (eof-object? keyword)
+ (error "EOF while reading headers."))
+ (if (not (string-ci=? keyword "end"))
+ (let ((keyword (intern keyword))
+ (datum (read-line port)))
+ (if (eof-object? datum)
+ (error "Missing command datum:" keyword))
+ (if debug-request-headers?
+ (write-line (list keyword datum)))
+ (case keyword
+ ((METHOD)
+ (let ((method (intern datum)))
+ (if (not (memq method '(GET POST)))
+ (error "Unknown HTTP method:" method))
+ (set-http-message-method! request method)))
+ ((URL)
+ (receive (url parameters) (parse-url datum)
+ (set-http-message-url! request url)
+ (set-http-message-url-parameters! request parameters)))
+ ((CONTENT-LENGTH)
+ (set-http-message-entity!
+ request
+ (make-string
+ (or (string->number datum)
+ (error "Invalid Content-Length:" datum)))))
+ ((COOKIE)
+ (set-http-message-cookie-parameters!
+ request
+ (parse-parameters datum)))
+ (else
+ (add-header request keyword datum)))
+ (loop)))))
+ (let ((entity (http-message-entity request)))
+ (if entity
+ (begin
+ (if (fix:> (string-length entity) 0)
+ (read-string! entity port)))))
+ request))
+
+(define debug-request-headers? #f)
+
+(define (parse-url url)
+ (let ((q (string-find-next-char url #\?)))
+ (if q
+ (values (string-head url q)
+ (parse-parameters (string-tail url (fix:+ q 1))))
+ (values url '()))))
+\f
+(define (maybe-parse-post-variables request)
+ (let ((entity (http-message-entity request)))
+ (if (and entity (eq? 'POST (http-message-method request)))
+ (begin
+ (set-http-message-post-parameters! request (parse-parameters entity))
+ (set-http-message-entity! request #f)
+ (if debug-post-variables?
+ (pp (http-message-post-parameters request)))))))
+
+(define debug-post-variables? #f)
+
+(define (parse-parameters string)
+ (let loop ((parameters (burst-string string #\& #f)))
+ (if (pair? parameters)
+ (let ((parameter (car parameters))
+ (tail (loop (cdr parameters))))
+ (let ((e (string-find-next-char parameter #\=)))
+ (if e
+ (cons (cons (string->symbol (string-head parameter e))
+ (decode-parameter-value parameter
+ (fix:+ e 1)
+ (string-length parameter)))
+ tail)
+ tail)))
+ '())))
+
+(define (decode-parameter-value string start end)
+ (call-with-output-string
+ (lambda (port)
+ (let loop ((start start))
+ (receive (char start) (decode-parameter-char string start end)
+ (if char
+ (if (char=? char #\return)
+ (receive (char* start*)
+ (decode-parameter-char string start end)
+ (if (eqv? char* #\newline)
+ (begin
+ (newline port)
+ (loop start*))
+ (begin
+ (write-char char port)
+ (loop start))))
+ (begin
+ (write-char char port)
+ (loop start)))))))))
+
+(define (decode-parameter-char string start end)
+ (if (fix:< start end)
+ (let ((char (string-ref string start)))
+ (cond ((not (char=? char #\%))
+ (values (if (char=? char #\+) #\space char)
+ (fix:+ start 1)))
+ ((fix:<= (fix:+ start 3) end)
+ (let ((d1 (char->digit (string-ref string (fix:+ start 1)) 16))
+ (d2 (char->digit (string-ref string (fix:+ start 2)) 16)))
+ (if (and d1 d2)
+ (values (integer->char (+ (* 16 d1) d2))
+ (fix:+ start 3))
+ (values #f start))))
+ (else
+ (values #f start))))
+ (values #f #f)))
+\f
+;;;; HTTP message datatype
+
+(define-structure (http-message (constructor make-http-message ()))
+ (headers '())
+ (headers-tail '())
+ (entity #f)
+ (method #f)
+ (url #f)
+ (url-parameters '())
+ (post-parameters '())
+ (cookie-parameters '()))
+
+(define (add-header message keyword datum)
+ (let ((new (list (cons keyword datum)))
+ (tail (http-message-headers-tail message)))
+ (if tail
+ (set-cdr! tail new)
+ (set-http-message-headers! message new))
+ (set-http-message-headers-tail! message new)))
+
+(define (set-entity message entity)
+ (add-header message
+ 'CONTENT-LENGTH
+ (number->string
+ (cond ((string? entity)
+ (string-length entity))
+ ((pathname? entity)
+ (file-length entity))
+ (else
+ (error:wrong-type-argument entity
+ "string or pathname"
+ 'SET-ENTITY)))))
+ (set-http-message-entity! message entity))
+
+(define (write-response message port)
+ (for-each (lambda (header)
+ ;; Kludge: mod-lisp uses case-sensitive comparisons for
+ ;; these headers.
+ (write-string (case (car header)
+ ((CONTENT-LENGTH) "Content-Length")
+ ((CONTENT-TYPE) "Content-Type")
+ ((KEEP-SOCKET) "Keep-Socket")
+ ((LAST-MODIFIED) "Last-Modified")
+ ((LOCATION) "Location")
+ ((LOG) "Log")
+ ((LOG-ERROR) "Log-Error")
+ ((NOTE) "Note")
+ ((SET-COOKIE) "Set-Cookie")
+ ((STATUS) "Status")
+ (else (symbol-name (car header))))
+ port)
+ (newline port)
+ (write-string (cdr header) port)
+ (newline port))
+ (http-message-headers message))
+ (write-string "end" port)
+ (newline port)
+ (let ((entity (http-message-entity message)))
+ (cond ((string? entity)
+ (write-string entity port))
+ ((pathname? entity)
+ (call-with-input-file entity
+ (lambda (input)
+ (port->port-copy input port))))
+ (else
+ (error "Illegal HTTP entity:" entity)))))
+\f
+;;;; Status messages
+
+(define (status-response code extra)
+ (let ((response (make-http-message)))
+ (status-response! response code extra)
+ response))
+
+(define (status-response! response code extra)
+ (add-status-header response code)
+ (add-content-type-header response 'text/html)
+ (set-entity response
+ (call-with-output-string
+ (lambda (port)
+ (let ((message (status-message code))
+ (start
+ (lambda (name)
+ (write-char #\< port)
+ (write-string name port)
+ (write-char #\> port)
+ (newline port)))
+ (end
+ (lambda (name)
+ (write-char #\< port)
+ (write-char #\/ port)
+ (write-string name port)
+ (write-char #\> port)
+ (newline port))))
+ (start "html")
+ (start "head")
+ (write-string "<title>" port)
+ (write-string message port)
+ (write-string "</title>" port)
+ (newline port)
+ (end "head")
+ (start "body")
+ (write-string "<h1>" port)
+ (write-string message port)
+ (write-string "</h1>" port)
+ (newline port)
+ (if extra
+ (begin
+ (display extra port)
+ (newline port)))
+ (end "body")
+ (end "html"))))))
+
+(define (status-message code)
+ (case code
+ ((200) "OK")
+ ((404) "Not Found")
+ ((500) "Internal Server Error")
+ (else (error "Unknown status code:" code))))
+
+(define (add-status-header message code)
+ (add-header message
+ 'STATUS
+ (call-with-output-string
+ (lambda (port)
+ (write code port)
+ (write-char #\space port)
+ (write-string (status-message code) port)))))
+
+(define (add-content-type-header message type)
+ (add-header message 'CONTENT-TYPE (symbol-name type)))
+\f
+;;;; Request/response accessors
+
+(let ((defaccess
+ (lambda (name accessor)
+ (define-expander name
+ (lambda ()
+ (accessor *current-request*))))))
+ (defaccess 'HTTP-REQUEST-ENTITY http-message-entity)
+ (defaccess 'HTTP-REQUEST-METHOD http-message-method)
+ (defaccess 'HTTP-REQUEST-URL http-message-url))
+
+(let ((defget
+ (lambda (name accessor)
+ (define-expander name
+ (lambda (keyword #!optional error?)
+ (let ((p (assq keyword (accessor *current-request*))))
+ (if p
+ (cdr p)
+ (begin
+ (if (and (not (default-object? error?)) error?)
+ (error:bad-range-argument keyword name))
+ #f)))))
+ (define-expander (symbol-append name '-bindings)
+ (lambda ()
+ (accessor *current-request*))))))
+ (defget 'HTTP-REQUEST-HEADER http-message-headers)
+ (defget 'HTTP-REQUEST-URL-PARAMETER http-message-url-parameters)
+ (defget 'HTTP-REQUEST-POST-PARAMETER http-message-post-parameters)
+ (defget 'HTTP-REQUEST-COOKIE-PARAMETER http-message-cookie-parameters))
+
+(define-expander 'HTTP-REQUEST-POST-PARAMETER-MULTIPLE
+ (lambda (keyword)
+ (let loop
+ ((bindings (http-message-post-parameters *current-request*))
+ (strings '()))
+ (if (pair? bindings)
+ (loop (cdr bindings)
+ (if (eq? (caar bindings) keyword)
+ (cons (cdar bindings) strings)
+ strings))
+ (reverse! strings)))))
+
+(define-expander 'HTTP-REQUEST-PATHNAME
+ (lambda ()
+ *current-pathname*))
+\f
+(define-expander 'HTTP-RESPONSE-HEADER
+ (lambda (keyword datum)
+ (guarantee-symbol keyword 'HTTP-RESPONSE-HEADER)
+ (guarantee-string datum 'HTTP-RESPONSE-HEADER)
+ (if (memq keyword '(STATUS CONTENT-LENGTH))
+ (error "Illegal header keyword:" keyword))
+ (add-header *current-response* keyword datum)))
+
+(define-expander 'HTTP-STATUS-RESPONSE
+ (lambda (code extra)
+ (guarantee-exact-nonnegative-integer code 'HTTP-STATUS-RESPONSE)
+ (guarantee-string extra 'HTTP-STATUS-RESPONSE)
+ (status-response! *current-response* code extra)))
+
+(define-expander 'SERVER-ROOT-DIR
+ (lambda ()
+ *root-dir*))
+
+(define-expander 'HTTP-REQUEST-USER-NAME
+ (lambda ()
+ (let ((auth (http-request-header 'authorization)))
+ (and auth
+ (cond ((string-prefix? "Basic " auth)
+ (decode-basic-auth-header auth 6 (string-length auth)))
+ (else
+ (error "Unknown authorization header format:" auth)))))))
+
+(define (decode-basic-auth-header string start end)
+ (let ((auth
+ (call-with-output-string
+ (lambda (port)
+ (let ((ctx (decode-base64:initialize port #t)))
+ (decode-base64:update ctx string start end)
+ (decode-base64:finalize ctx))))))
+ (let ((colon (string-find-next-char auth #\:)))
+ (if (not colon)
+ (error "Malformed authorization string."))
+ (string-head auth colon))))
+\f
+;;;; Utilities
+
+(define (port->port-copy input output #!optional buffer-size)
+ (let ((buffer
+ (make-string (if (default-object? buffer-size)
+ #x10000
+ buffer-size))))
+ (let loop ()
+ (let ((n (read-string! buffer input)))
+ (cond ((not n)
+ (loop))
+ ((> n 0)
+ (write-substring buffer 0 n output)
+ (loop)))))))
+
+(define (for-each-file-line pathname procedure)
+ (call-with-input-file pathname
+ (lambda (port)
+ (for-each-port-line port procedure))))
+
+(define (for-each-port-line port procedure)
+ (let loop ()
+ (let ((line (read-line port)))
+ (if (not (eof-object? line))
+ (begin
+ (procedure line)
+ (loop))))))
+
+(initialize-mime-extensions)
\ No newline at end of file
--- /dev/null
+#| -*-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)))
+\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 2003/12/29 05:24:51 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))
+\f
+(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)
+ ;; Should be "application/xhtml+xml" -- IE loses.
+ (http-response-header 'content-type "text/html")
+ (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 (xml-document-misc-1 document))
+ xhtml-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 (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 ((*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)
+ (let ((root (xml-document-root document)))
+ (strip-xdoc-space document)
+ (save-structure-properties root)))
+
+(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 ((get-misc-id
+ (let ((prefix (string-append prefix (number->string n) "-"))
+ (count 0))
+ (lambda ()
+ (let ((id
+ (string->symbol
+ (string-append prefix
+ (string-pad-left (number->string count)
+ 4
+ #\0)))))
+ (set! count (+ count 1))
+ id)))))
+ (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 (get-misc-id)))
+ (if (xml-element? item)
+ (for-each walk-html (xml-element-contents item))))
+ (loop (cdr items) count))))))))))
+
+(define-expander 'xdoc-part-number
+ (lambda (name)
+ (if (string-prefix? "xdoc_" name)
+ (string-tail name 5)
+ name)))
+\f
+(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))))))
+\f
+(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 (xdoc-attributes root 'xmlns xhtml-iri)
+ "\n"
+ (head #f
+ "\n "
+ (style-link "/styles/xdoc.css")
+ (append-map (lambda (item)
+ (if (xd:head? item)
+ (xml-element-contents item)
+ '()))
+ (xml-element-contents root)))
+ "\n"
+ (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?)
+ (let ((expand-xdoc
+ (lambda (elt valid-content?)
+ (if (not (valid-content? elt))
+ (error "Illegal content in this context:" elt))
+ (let ((handler (xdoc-html-generator elt)))
+ (if (not handler)
+ (error "Unhandled element type:" (xml-element-name elt)))
+ (handler elt)))))
+ (lambda (items)
+ (map (lambda (item)
+ (cond ((xdoc-element? item)
+ (expand-xdoc item
+ (lambda (elt)
+ (or (memq (xdoc-element-type elt)
+ '(internal-container
+ output
+ content-selector
+ action))
+ (extra-content? elt)))))
+ ((xml-element? item)
+ (generate-xdoc-in-html item
+ (lambda (elt)
+ (expand-xdoc elt
+ (lambda (elt)
+ (memq (xdoc-element-type elt)
+ '(output content-selector action)))))))
+ (else item)))
+ items)))
+ generate-answer-block))
+
+(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
+ (form (attributes
+ 'method "post"
+ 'action (or (find-attribute 'form-url elt #f) (http-request-url)))
+ (generate-container-items (xml-element-contents elt)
+ (lambda (elt)
+ (or (xd:head? elt)
+ (xd:due-date? elt)))))))
+
+(define-html-generator 'head
+ (lambda (elt)
+ elt
+ '()))
+
+(define-html-generator 'due-date
+ (lambda (elt)
+ (let ((dt (due-date->decoded-time elt)))
+ (p (merge-attributes (xdoc-due-date-attributes dt)
+ (preserved-attributes elt))
+ (xdoc-due-date-string dt)))))
+
+(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-expander 'xdoc-due-date-attributes
+ (lambda (dt)
+ (attributes 'class
+ (string-append "xdoc-due-date "
+ (if (decoded-time-in-past? dt)
+ "xdoc-due-date-overdue"
+ "xdoc-due-date-on-time")))))
+
+(define-expander 'xdoc-due-date-string
+ (lambda (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 ((elt (find-named-child 'due-date *xdoc-root* #f)))
+ (and elt
+ (decoded-time-in-past? (due-date->decoded-time elt)))))
+
+(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)
+ (attributes 'class
+ (let ((base (string-append "xdoc-problem-" part)))
+ (string-append base "-" (number->string depth)
+ " " base))))))
+ (let ((label-attrs (class-attrs "label"))
+ (body-attrs (class-attrs "body")))
+ (list (if (and (> count 1) (problem-separator? elt))
+ (list (hr) "\n")
+ '())
+ (if (> depth 1)
+ (case (problem-group-type (nearest-container elt))
+ ((dl)
+ (list (dt label-attrs
+ (if formatter
+ (formatter prefix number elt)
+ (list number ":")))
+ "\n"
+ (dd body-attrs "\n" body)))
+ ((ol)
+ (li (append body-attrs (attributes 'value number))
+ body))
+ ((ul) (li body-attrs body))
+ (else (div body-attrs body)))
+ (list (p label-attrs
+ (if formatter
+ (formatter prefix number elt)
+ (list "Problem " prefix number)))
+ "\n"
+ (div body-attrs "\n" body))))))))))
+
+(define (generate-problem-body elt)
+ (let ((wrap
+ (case (problem-group-type elt)
+ ((dl) dl)
+ ((ol) ol)
+ ((ul) ul)
+ (else div)))
+ (attrs (xdoc-attributes elt 'class "xdoc-problem-group"))
+ (generate-group
+ (lambda (items)
+ (generate-container-items items (lambda (elt) elt #f)))))
+ (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
+ (table (attributes 'class "xdoc-answer-block"
+ 'cellspacing "8")
+ (append-map (lambda (elt)
+ (list "\n "
+ (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 "
+ (td (xdoc-attributes elt
+ 'class (symbol-append '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)))
+ (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
+ (select (xdoc-attributes elt
+ 'name (xdoc-db-id elt)
+ 'size size
+ 'disabled (and submitter 'disabled))
+ "\n"
+ (option #f menu-dummy-string)
+ (map (lambda (v)
+ (list "\n"
+ (option (attributes '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)
+ (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)))
+ (table
+ (attributes 'class "xdoc-radio-buttons-input")
+ (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
+ (td #f
+ (input 'type 'radio
+ 'name id
+ 'value value*
+ 'checked (string=? value* value)
+ 'disabled (and submitter 'disabled)))
+ (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 (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-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?
+ (let ((machine-epsilon
+ (let loop ((e 1.))
+ (if (> (+ e 1) 1)
+ (loop (/ e 2))
+ (* 2 e)))))
+ (lambda (z expected tolerance)
+ (if (= tolerance 0)
+ (= z expected)
+ (<= (magnitude (- z expected))
+ (/ (* (max tolerance machine-epsilon)
+ (+ (magnitude z)
+ (magnitude tolerance)
+ 2))
+ 2))))))
+
+(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-append 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"
+ (blockquote
+ (xdoc-attributes elt
+ 'class
+ (string-append "xdoc-"
+ (symbol-name type)
+ "-blockquote"))
+ (xml-element-contents elt))
+ "\n"))
+ (button
+ (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))
+ (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)
+ (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))
+ (div (xdoc-attributes elt)
+ (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-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))))
+
+(define (descendant-outputs-submitted? elt)
+ (for-all? (descendant-outputs elt) output-submitted?))
+
+(define (descendant-outputs elt)
+ (matching-descendants-or-self elt xdoc-output?))
+\f
+;;;; Actions
+
+(define-html-generator 'check-action
+ (lambda (elt)
+ (submission-action elt 'check)))
+
+(define-html-generator 'submit-action
+ (lambda (elt)
+ (submission-action elt 'submit)))
+
+(define (submission-action elt prefix)
+ (let ((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
+ (input
+ (xdoc-attributes
+ elt
+ 'class "xdoc-submit-action"
+ 'type 'submit
+ 'name (symbol-append prefix '- (xdoc-db-id container))
+ 'value
+ (string-append (string-capitalize (symbol-name prefix))
+ " answer"
+ (if (fix:= (length inputs) 1) "" "s"))))))))
+
+(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 attributes 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
+(let ((define-element
+ (lambda (local content-type elt-type)
+ (let ((qname (symbol-append 'xd: local)))
+ (define-expander qname
+ ((if (eq? content-type 'empty)
+ empty-element-constructor
+ standard-element-constructor)
+ qname xdoc-iri))
+ (define-expander (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 '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 '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 'check-action 'empty 'action)
+ (define-element 'submit-action 'empty 'action))
+
+(define-expander 'xd:true-false
+ (lambda keyword-list
+ (xd:radio-buttons (apply attributes keyword-list)
+ (xd:radio-entry (attributes 'value 'true) "True")
+ (xd:radio-entry (attributes 'value 'false) "False"))))
+
+(define-expander 'xd:true-false?
+ (lambda (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
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: xhtml-expander.scm,v 1.1 2003/12/29 05:24:59 uid67408 Exp $
+
+Copyright 2002,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.
+
+|#
+
+;;;; XHTML+Scheme expander
+
+(declare (usual-integrations))
+(load-option 'xml)
+\f
+(define default-expander-directory
+ (merge-pathnames "*.xml"
+ (directory-pathname (current-load-pathname))))
+
+(define (expand-xhtml-directory #!optional directory)
+ (for-each expand-xhtml-file
+ (directory-read (if (default-object? directory)
+ default-expander-directory
+ directory))))
+
+(define (expand-xhtml-file input #!optional output)
+ (let ((document
+ (read/expand-xml-file input
+ (make-expansion-environment input))))
+ (let ((root (xml-document-root document)))
+ (set-xml-element-contents!
+ root
+ (cons* "\n"
+ (make-xml-comment
+ (string-append
+ " This document was automatically generated from \""
+ (file-namestring input)
+ "\"\n on "
+ (universal-time->local-time-string (get-universal-time))
+ ". "))
+ (xml-element-contents root))))
+ (let ((output
+ (if (default-object? output)
+ (pathname-new-type input "html")
+ output)))
+ ((if (output-port? output) write-xml write-xml-file)
+ document output 'INDENT-DTD? #t))))
+
+(define (read/expand-xml-file pathname environment)
+ (with-working-directory-pathname (directory-pathname pathname)
+ (lambda ()
+ (fluid-let ((*sabbr-table* (make-eq-hash-table)))
+ (read-xml-file pathname
+ `((scheme ,(pi-expander environment))
+ (svar ,svar-expander)
+ (sabbr ,sabbr-expander)))))))
+
+(define (make-expansion-environment pathname)
+ (let ((pathname (merge-pathnames pathname))
+ (environment (extend-top-level-environment expander-environment)))
+ (environment-define environment 'document-pathname pathname)
+ (environment-define environment 'emit emit)
+ (environment-define environment 'load
+ (let ((directory (directory-pathname pathname)))
+ (lambda (pathname)
+ (load (merge-pathnames pathname directory)
+ environment))))
+ (environment-define environment 'define-sabbr define-sabbr)
+ (environment-define environment 'get-sabbr get-sabbr)
+ environment))
+
+(define ((pi-expander environment) text)
+ (fluid-let ((*outputs* (cons '() '()))
+ (load/suppress-loading-message? #t))
+ (let ((port (open-input-string text)))
+ (let loop ()
+ (let ((expression (read port)))
+ (if (not (eof-object? expression))
+ (begin
+ (expander-eval expression environment)
+ (loop))))))
+ (car *outputs*)))
+\f
+(define expander-eval eval)
+(define expander-environment)
+(define server-environment (the-environment))
+(define expander-directory (directory-pathname (current-load-pathname)))
+
+(define (initialize-expander-environment)
+ (set! expander-environment
+ (let ((e (make-top-level-environment)))
+ (load (merge-pathnames "xhtml" expander-directory) e)
+ e))
+ (for-each (lambda (name)
+ (link-variables server-environment name
+ expander-environment name))
+ (environment-bound-names expander-environment)))
+
+(define (define-expander name value)
+ (environment-define expander-environment name value)
+ (link-variables server-environment name
+ expander-environment name))
+
+(initialize-expander-environment)
+
+(define (svar-expander text)
+ (list (make-xml-element 'code '() (list (string-trim text)))))
+
+(define (sabbr-expander text)
+ (get-sabbr (intern (string-trim text))))
+
+(define (define-sabbr name expansion)
+ (hash-table/put! *sabbr-table* name (flatten expansion)))
+
+(define (get-sabbr name)
+ (let ((expansion (hash-table/get *sabbr-table* name 'NO-EXPANSION)))
+ (if (eq? expansion 'NO-EXPANSION)
+ (error "Invalid sabbr name:" name))
+ expansion))
+
+(define (emit . content)
+ (emit* content *outputs*))
+
+(define (emit* content q)
+ (let ((tail (flatten content)))
+ (if (pair? tail)
+ (begin
+ (if (pair? (cdr q))
+ (set-cdr! (cdr q) tail)
+ (set-car! q tail))
+ (set-cdr! q (last-pair tail))))))
+
+(define (flatten items)
+ (cond ((pair? items) (append-map! flatten items))
+ ((null? items) '())
+ (else (list items))))
+
+(define *outputs*)
+(define *sabbr-table*)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: xhtml.scm,v 1.1 2003/12/29 05:24:55 uid67408 Exp $
+
+Copyright 2002,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.
+
+|#
+
+;;;; XHTML support
+
+(declare (usual-integrations))
+\f
+(define xhtml-external-dtd
+ (make-xml-external-id "-//W3C//DTD XHTML 1.0 Strict//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"))
+
+(define xhtml-dtd
+ (make-xml-dtd 'html xhtml-external-dtd '()))
+
+(define xhtml-iri
+ (make-xml-namespace-iri "http://www.w3.org/1999/xhtml"))
+
+(define-syntax define-standard-element
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (if (syntax-match? '(IDENTIFIER) (cdr form))
+ (let ((name (cadr form)))
+ `(DEFINE ,name
+ (STANDARD-ELEMENT-CONSTRUCTOR ',name XHTML-IRI)))
+ (ill-formed-syntax form)))))
+
+(define (standard-element-constructor simple iri)
+ (let ((name (make-xml-name simple iri)))
+ (lambda (attrs . items)
+ (make-xml-element name
+ (if (not attrs)
+ '()
+ attrs)
+ (flatten-xml-element-contents items)))))
+
+(define (flatten-xml-element-contents item)
+ (letrec
+ ((scan-item
+ (lambda (item tail)
+ (cond ((xml-content-item? item) (cons item tail))
+ ((pair? item) (scan-list item tail))
+ ((or (not item) (null? item)) tail)
+ (else (cons (convert-xhtml-string-value item) tail)))))
+ (scan-list
+ (lambda (items tail)
+ (if (pair? items)
+ (scan-item (car items)
+ (scan-list (cdr items) tail))
+ (begin
+ (if (not (null? items))
+ (error:wrong-type-datum items "list"))
+ tail)))))
+ (scan-item item '())))
+
+(define (convert-xhtml-string-value value)
+ (cond ((symbol? value) (symbol-name value))
+ ((number? value) (number->string value))
+ ((xml-namespace-iri? value) (xml-namespace-iri-string value))
+ (else (error:wrong-type-datum value "string value"))))
+\f
+(define-standard-element a)
+(define-standard-element abbr)
+(define-standard-element acronym)
+(define-standard-element address)
+(define-standard-element b)
+(define-standard-element big)
+(define-standard-element blockquote)
+(define-standard-element body)
+(define-standard-element button)
+(define-standard-element caption)
+(define-standard-element cite)
+(define-standard-element code)
+(define-standard-element col)
+(define-standard-element colgroup)
+(define-standard-element dd)
+(define-standard-element defn)
+(define-standard-element del)
+(define-standard-element dir)
+(define-standard-element div)
+(define-standard-element dl)
+(define-standard-element dt)
+(define-standard-element em)
+(define-standard-element form)
+(define-standard-element h1)
+(define-standard-element h2)
+(define-standard-element h3)
+(define-standard-element h4)
+(define-standard-element h5)
+(define-standard-element head)
+(define-standard-element html)
+(define-standard-element i)
+(define-standard-element ins)
+(define-standard-element kbd)
+(define-standard-element li)
+(define-standard-element listing)
+(define-standard-element menu)
+(define-standard-element ol)
+(define-standard-element optgroup)
+(define-standard-element option)
+(define-standard-element p)
+(define-standard-element pre)
+(define-standard-element q)
+(define-standard-element s)
+(define-standard-element samp)
+(define-standard-element script)
+(define-standard-element select)
+(define-standard-element small)
+(define-standard-element span)
+(define-standard-element strike)
+(define-standard-element strong)
+(define-standard-element sub)
+(define-standard-element sup)
+(define-standard-element table)
+(define-standard-element tbody)
+(define-standard-element td)
+(define-standard-element textarea)
+(define-standard-element tfoot)
+(define-standard-element th)
+(define-standard-element thead)
+(define-standard-element title)
+(define-standard-element tr)
+(define-standard-element tt)
+(define-standard-element u)
+(define-standard-element ul)
+(define-standard-element var)
+\f
+(define-syntax define-empty-element
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (if (syntax-match? '(IDENTIFIER) (cdr form))
+ (let ((name (cadr form)))
+ `(DEFINE ,name
+ (EMPTY-ELEMENT-CONSTRUCTOR ',name XHTML-IRI)))
+ (ill-formed-syntax form)))))
+
+(define (empty-element-constructor simple iri)
+ (let ((name (make-xml-name simple iri)))
+ (lambda keyword-list
+ (make-xml-element name
+ (if (and (pair? keyword-list)
+ (list-of-type? (car keyword-list)
+ xml-attribute?)
+ (null? (cdr keyword-list)))
+ (car keyword-list)
+ (apply attributes keyword-list))
+ '()))))
+
+(define-empty-element br)
+(define-empty-element hr)
+(define-empty-element img)
+(define-empty-element input)
+(define-empty-element link)
+(define-empty-element meta)
+
+(define (attributes . keyword-list)
+ (let loop ((bindings keyword-list))
+ (if (and (pair? bindings)
+ (xml-name? (car bindings))
+ (pair? (cdr bindings)))
+ (let ((value (cadr bindings))
+ (tail (loop (cddr bindings))))
+ (if value
+ (cons (make-xml-attribute
+ (car bindings)
+ (cond ((eq? value #t) (symbol-name (car bindings)))
+ ((xml-char-data? value) value)
+ (else (convert-xhtml-string-value value))))
+ tail)
+ tail))
+ (begin
+ (if (not (null? bindings))
+ (error:wrong-type-argument keyword-list
+ "keyword list"
+ 'ATTRIBUTES))
+ '()))))
+\f
+(define (href iri . contents)
+ (apply a
+ (attributes 'href iri)
+ contents))
+
+(define (id-def tag . contents)
+ (apply a
+ (attributes 'id tag
+ 'name tag)
+ contents))
+
+(define (id-ref tag . contents)
+ (apply href (string-append "#" tag) contents))
+
+(define (rel-link rel iri)
+ (link 'rel rel
+ 'href iri))
+
+(define (style-link iri)
+ (link 'rel "stylesheet"
+ 'href iri
+ 'type "text/css"))
+
+(define (http-equiv name value)
+ (meta 'http-equiv name
+ 'content value))
+
+(define (style . keyword-list)
+ (let loop ((bindings keyword-list))
+ (if (and (pair? bindings)
+ (symbol? (car bindings))
+ (pair? (cdr bindings))
+ (string? (cadr bindings)))
+ (string-append (symbol-name (car bindings))
+ ": "
+ (cadr bindings)
+ (if (pair? (cddr bindings))
+ (string-append "; " (loop (cddr bindings)))
+ ";"))
+ (begin
+ (if (not (null? bindings))
+ (error:wrong-type-argument keyword-list "keyword list" 'STYLE))
+ ""))))
+
+(define (comment . strings)
+ (make-xml-comment (string-append " " (apply string-append strings) " ")))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: xmlrpc.scm,v 1.1 2003/12/29 05:25:02 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.
+
+|#
+
+;;;; MIT/GNU Scheme XML-RPC implementation (requires mod-lisp)
+
+(declare (usual-integrations))
+\f
+(define-subtree-handler "xmlrpc" 'text/xml
+ (lambda (pathname port)
+ (if (eq? (http-request-method) 'post)
+ (let ((entity (http-request-entity)))
+ (if entity
+ (let ((document (read-xml (open-input-string entity))))
+ (if document
+ (write-xml (xml-rpc:process-request document pathname)
+ port)
+ (http-status-response 400 "Ill-formed XML entity")))
+ (http-status-response 400 "Missing XML entity")))
+ (begin
+ (http-status-response 405 "XML-RPC requires POST method.")
+ (http-response-header 'allow "POST")))))
+
+(define (xml-rpc:process-request document pathname)
+ (let ((result
+ (ignore-errors
+ (lambda ()
+ (receive (name params) (xml-rpc:parse-request document)
+ (let ((handler (xml-rpc:get-method-handler pathname name)))
+ (if (not handler)
+ (error "Unknown method name:" name))
+ (xml-rpc:response
+ (with-working-directory-pathname (directory-pathname pathname)
+ (lambda ()
+ (apply handler params))))))))))
+ (if (condition? result)
+ (xml-rpc:fault 1 (condition/report-string result))
+ result)))
+
+(define (xml-rpc:get-method-handler pathname name)
+ (let ((methods (make-string-hash-table)))
+ (let ((environment (make-expansion-environment pathname)))
+ (environment-define environment 'define-xmlrpc-method
+ (lambda (name handler)
+ (hash-table/put! methods name handler)))
+ (fluid-let ((load/suppress-loading-message? #t))
+ (load pathname environment)))
+ (hash-table/get methods name #f)))
+
+(define (xml-rpc:response object)
+ (rpc-elt:method-response
+ (rpc-elt:params
+ (rpc-elt:param
+ (rpc-elt:value (xml-rpc:encode-object object))))))
+
+(define (xml-rpc:fault code message . irritants)
+ (let ((message
+ (call-with-output-string
+ (lambda (port)
+ (format-error-message message irritants port)))))
+ (rpc-elt:method-response
+ (rpc-elt:fault
+ (rpc-elt:value
+ (rpc-elt:struct
+ (rpc-elt:member (rpc-elt:name "faultCode")
+ (rpc-elt:value (rpc-elt:int (number->string code))))
+ (rpc-elt:member (rpc-elt:name "faultString")
+ (rpc-elt:value (rpc-elt:string message)))))))))
+\f
+(define (xml-rpc:parse-request document)
+ (let ((elt (xml-document-root document))
+ (lose
+ (lambda ()
+ (error:bad-range-argument (xml->string document) #f))))
+ (if (not (xml-name=? (xml-element-name elt) '|methodCall|))
+ (lose))
+ (values (let ((s
+ (xml-rpc:content-string
+ (xml-rpc:named-child '|methodName| elt lose)
+ lose)))
+ (if (not (re-string-match "\\`[a-zA-Z0-9_.:/]+\\'" s))
+ (lose))
+ s)
+ (let ((elt (xml-rpc:named-child 'params elt #f)))
+ (if elt
+ (xml-rpc:parse-params elt lose)
+ '())))))
+
+(define (xml-rpc:parse-params elt lose)
+ (map (lambda (elt)
+ (xml-rpc:decode-value (xml-rpc:single-named-child 'value elt lose)
+ lose))
+ (xml-rpc:named-children 'param elt lose)))
+\f
+(define (xml-rpc:named-children name elt lose)
+ (let loop ((items (xml-element-contents elt)))
+ (if (pair? items)
+ (let ((item (car items))
+ (rest (loop (cdr items))))
+ (if (xml-element? item)
+ (begin
+ (if (not (xml-name=? (xml-element-name item) name))
+ (lose))
+ (cons item rest))
+ (begin
+ (if (not (or (xml-whitespace-string? item)
+ (xml-comment? item)))
+ (lose))
+ rest)))
+ '())))
+
+(define (xml-rpc:children elt lose)
+ (let loop ((items (xml-element-contents elt)))
+ (if (pair? items)
+ (let ((item (car items))
+ (rest (loop (cdr items))))
+ (if (xml-element? item)
+ (cons item rest)
+ (begin
+ (if (not (or (xml-whitespace-string? item)
+ (xml-comment? item)))
+ (lose))
+ rest)))
+ '())))
+
+(define (xml-rpc:named-child name elt lose)
+ (or (find-matching-item (xml-element-contents elt)
+ (lambda (item)
+ (and (xml-element? item)
+ (xml-name=? (xml-element-name item) name))))
+ (and lose (lose))))
+
+(define (xml-rpc:single-child elt lose)
+ (let ((children (xml-rpc:children elt lose)))
+ (if (not (and (pair? children)
+ (null? (cdr children))))
+ (lose))
+ (car children)))
+
+(define (xml-rpc:single-named-child name elt lose)
+ (let ((child (xml-rpc:single-child elt lose)))
+ (if (not (xml-name=? (xml-element-name child) name))
+ (lose))
+ child))
+\f
+(define (xml-rpc:decode-object elt lose)
+ (case (xml-element-name elt)
+ ((boolean)
+ (let ((s (xml-rpc:content-string elt lose)))
+ (cond ((string=? s "0") #f)
+ ((string=? s "1") #t)
+ (else (lose)))))
+ ((|dateTime.iso8601|)
+ (safe-call lose
+ iso8601-string->decoded-time
+ (xml-rpc:content-string elt lose)))
+ ((double)
+ (let ((x (string->number (xml-rpc:content-string elt lose))))
+ (if (not (and x (flo:flonum? x)))
+ (lose))
+ x))
+ ((i4 int)
+ (let ((n (string->number (xml-rpc:content-string elt lose))))
+ (if (not (and n
+ (exact-integer? n)
+ (<= #x-80000000 n #x7fffffff)))
+ (lose))
+ n))
+ ((string)
+ (xml-rpc:content-string elt lose))
+ ((base64)
+ (safe-call lose
+ (lambda (string)
+ (call-with-output-string
+ (lambda (port)
+ (call-with-decode-base64-output-port port #f
+ (lambda (port)
+ (write-string string port))))))
+ (xml-rpc:content-string elt lose)))
+ ((array)
+ (map (lambda (elt) (xml-rpc:decode-value elt lose))
+ (xml-rpc:named-children 'value
+ (xml-rpc:single-named-child 'data elt lose)
+ lose)))
+ ((struct)
+ (map (lambda (elt)
+ (cons (string->symbol (xml-rpc:named-child 'name elt lose))
+ (xml-rpc:decode-value (xml-rpc:named-child 'value elt lose)
+ lose)))
+ (xml-rpc:named-children 'member elt lose)))
+ (else (lose))))
+
+(define (xml-rpc:content-string elt lose)
+ (let ((items (xml-element-contents elt)))
+ (if (not (and (pair? items)
+ (string? (car items))
+ (null? (cdr items))))
+ (lose))
+ (car items)))
+
+(define (safe-call lose procedure . arguments)
+ (let ((value (ignore-errors (lambda () (apply procedure arguments)))))
+ (if (condition? value)
+ (lose)
+ value)))
+
+(define (xml-rpc:decode-value elt lose)
+ (let ((items (xml-element-contents elt)))
+ (if (and (pair? items)
+ (string? (car items))
+ (null? (cdr items)))
+ (car items)
+ (xml-rpc:decode-object (xml-rpc:single-child elt lose) lose))))
+\f
+(define (xml-rpc:encode-object object)
+ (cond ((and (exact-integer? object)
+ (<= #x-80000000 object #x7fffffff))
+ (rpc-elt:int (number->string object)))
+ ((flo:flonum? object)
+ ;; Probably not right -- formatting issues
+ (rpc-elt:double (number->string object)))
+ ((boolean? object)
+ (rpc-elt:boolean? (if object "1" "0")))
+ ((string? object)
+ (if (utf8-string-valid? object)
+ (rpc-elt:string object)
+ (call-with-output-string
+ (lambda (port)
+ (let ((context (encode-base64:initialize port #f)))
+ (encode-base64:update context
+ object
+ 0
+ (string-length object))
+ (encode-base64:finalize context))))))
+ ((decoded-time? object)
+ (rpc-elt:date-time (decoded-time->iso8601-string object)))
+ ((and (pair? object)
+ (list-of-type? object
+ (lambda (item)
+ (and (pair? item)
+ (symbol? (car item))))))
+ (rpc-elt:struct
+ (map (lambda (item)
+ (rpc-elt:member (rpc-elt:name (symbol->string (car item)))
+ (xml-rpc:encode-value (cdr item))))
+ (cdr object))))
+ ((list? object)
+ (rpc-elt:array (rpc-elt:data (map xml-rpc:encode-value object))))
+ (else
+ (error:wrong-type-argument object
+ "an XML-RPC object"
+ 'xml-rpc:encode-object))))
+
+(define (xml-rpc:encode-value v)
+ (rpc-elt:value (xml-rpc:encode-object v)))
+
+(define (rpc-elt name)
+ (let ((make-elt
+ (standard-element-constructor name (null-xml-namespace-iri))))
+ (lambda contents
+ (apply make-elt #f contents))))
+
+(define rpc-elt:array (rpc-elt 'array))
+(define rpc-elt:base64 (rpc-elt 'base64))
+(define rpc-elt:boolean (rpc-elt 'boolean))
+(define rpc-elt:data (rpc-elt 'data))
+(define rpc-elt:date-time (rpc-elt '|dateTime.iso8601|))
+(define rpc-elt:double (rpc-elt 'double))
+(define rpc-elt:fault (rpc-elt 'fault))
+(define rpc-elt:i4 (rpc-elt 'i4))
+(define rpc-elt:int (rpc-elt 'int))
+(define rpc-elt:member (rpc-elt 'member))
+(define rpc-elt:method-call (rpc-elt '|methodCall|))
+(define rpc-elt:method-name (rpc-elt '|methodName|))
+(define rpc-elt:method-response (rpc-elt '|methodResponse|))
+(define rpc-elt:name (rpc-elt 'name))
+(define rpc-elt:param (rpc-elt 'param))
+(define rpc-elt:params (rpc-elt 'params))
+(define rpc-elt:string (rpc-elt 'string))
+(define rpc-elt:struct (rpc-elt 'struct))
+(define rpc-elt:value (rpc-elt 'value))
\ No newline at end of file
projects / mit-scheme.git / commitdiff