#| -*-Scheme-*-
-$Id: compile.scm,v 1.1 2003/12/29 05:24:29 uid67408 Exp $
+$Id: compile.scm,v 1.2 2003/12/29 07:30:39 uid67408 Exp $
Copyright 2003 Massachusetts Institute of Technology
|#
-;;;; XDOC/mod-lisp compilation
+;;;; SSP/XDOC compilation
+(load-option 'CREF)
(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
+ (for-each compile-file
+ '("db"
+ "expenv"
+ "matcher"
+ "mod-lisp"
+ "xdoc"
+ "xhtml"
+ "xhtml-expander"
+ "xmlrpc"))
+ (cref/generate-constructors "ssp")))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: db.scm,v 1.1 2003/12/29 05:24:32 uid67408 Exp $
+$Id: db.scm,v 1.2 2003/12/29 07:31:03 uid67408 Exp $
Copyright 2003 Massachusetts Institute of Technology
(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)
+(define (with-database-connection db-name 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))))
(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")))
+(define (db-run-query . strings)
+ (exec-pgsql-query (database-connection)
+ (string-append (apply string-append strings) ";")))
+
+(define (db-run-cmd . strings)
+ (let ((result (apply db-run-query strings)))
+ (let ((status (pgsql-cmd-status result)))
+ (pgsql-clear result)
+ status)))
+
+(define (db-quote object)
+ (if object
+ (if (exact-integer? object)
+ (number->string object)
+ (string-append "'"
+ (escape-pgsql-string
+ (if (symbol? object)
+ (symbol-name object)
+ object))
+ "'"))
+ "NULL"))
\f
;;;; Problem-set registration
-(define-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 (db-register-problem-set ps-number directory)
+ (db-run-cmd "DELETE FROM saved_inputs"
+ " WHERE ps_number = " (db-quote ps-number))
+ (db-run-cmd "DELETE FROM saved_outputs"
+ " WHERE ps_number = " (db-quote ps-number))
+ (db-run-cmd "DELETE FROM registered_outputs"
+ " WHERE ps_number = " (db-quote ps-number))
+ (let ((n-parts 0)
+ (n-outputs 0))
+ (for-each (lambda (pathname)
+ (if (not (string=? (pathname-name pathname) "index"))
+ (begin
+ (set! n-parts (+ n-parts 1))
+ (set! n-outputs
+ (+ n-outputs
+ (register-part-outputs ps-number
+ pathname)))))
+ unspecific)
+ (directory-read (merge-pathnames "*.xdoc" directory)))
+ (values n-parts n-outputs)))
(define (register-part-outputs ps-number pathname)
(with-xdoc-expansion-context ps-number pathname
", " (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?))))
+(define (db-registered-problem-sets)
+ (let ((result
+ (db-run-query "SELECT DISTINCT ps_number"
+ " FROM registered_outputs"
+ " ORDER BY ps_number")))
+ (let ((n (pgsql-n-tuples result)))
+ (do ((i 0 (+ i 1))
+ (numbers '()
+ (cons (string->number (pgsql-get-value result i 0))
+ numbers)))
+ ((= i n)
+ (pgsql-clear result)
+ (reverse! numbers))))))
+
+(define (db-ps-problem-names ps-number)
+ (let ((result
+ (db-run-query "SELECT name"
+ " FROM registered_outputs"
+ " WHERE ps_number = " (db-quote ps-number))))
+ (let ((n (pgsql-n-tuples result)))
+ (do ((i 0 (+ i 1))
+ (names '() (cons (pgsql-get-value result i 0) names)))
+ ((= i n)
+ (pgsql-clear result)
+ names)))))
+
+(define (db-problem-submitted? ps-number name user-name)
+ (let ((result
+ (db-run-query "SELECT submitter"
+ " FROM saved_outputs"
+ " WHERE ps_number = " (db-quote ps-number)
+ " AND name = " (db-quote name)
+ " AND user_name = " (db-quote user-name))))
+ (let ((submitted?
+ (and (> (pgsql-n-tuples result) 0)
+ (let ((v (pgsql-get-value result 0 0)))
+ (and v
+ (not (string-null? v)))))))
+ (pgsql-clear result)
+ submitted?)))
\f
-(define-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 (db-get-ps-structure)
+ (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)
" 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))))))
+(define (db-get-saved-output user-name ps-number name)
+ (let ((result
+ (db-run-query "SELECT correctness, submitter, late_p"
+ " FROM saved_outputs"
+ " WHERE user_name = " (db-quote user-name)
+ " AND ps_number = " (db-quote ps-number)
+ " AND name = " (db-quote name))))
+ (if (> (pgsql-n-tuples result) 0)
+ (let ((correctness (pgsql-get-value result 0 0))
+ (submitter (pgsql-get-value result 0 1))
+ (late? (string=? (pgsql-get-value result 0 2) "t")))
+ (pgsql-clear result)
+ (values correctness
+ (and submitter (string->symbol submitter))
+ late?))
+ (begin
+ (pgsql-clear result)
+ (values #f #f #f)))))
\f
;;;; Persistent values
-(define-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)
+(define (db-get-persistent-value 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 (db-set-persistent-value! 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 (db-intern-persistent-value! 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 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))))
+ ", " (db-quote (write-to-string object))
+ ")")
+ object)))))
+
+(define (db-delete-persistent-value! 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)
\f
;;;; Clear submitted/late
-(define-expander 'db-saved-submitters
- (lambda (user-name)
- (db-marked-submitters user-name "submitter IS NOT NULL")))
+(define (db-saved-submitters 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-late-submitters user-name)
+ (db-marked-submitters user-name "late_p"))
(define (db-marked-submitters user-name condition)
(let ((result
(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-clear-submitter 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 (db-clear-late-flag user-name number)
+ (receive (ps-number submitter) (parse-problem-number number)
+ (db-set-output-field user-name ps-number submitter "late_p = FALSE")))
(define (db-set-output-field user-name ps-number submitter assignment)
(let ((result
\f
;;;; Users
-(define-expander 'db-known-user?
- (lambda (user-name)
- (known-user? user-name #f)))
+(define (db-known-user? user-name)
+ (known-user? user-name #f))
(define (known-user? user-name for-update?)
(let ((result
(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))))
+(define (db-known-users condition)
+ (let ((result
+ (db-run-query "SELECT user_name"
+ " FROM users"
+ (case condition
+ ((enabled) " WHERE enabled_p")
+ ((disabled) " WHERE NOT enabled_p")
+ (else ""))
+ " ORDER BY user_name")))
+ (let ((n (pgsql-n-tuples result)))
+ (let loop ((i 0) (users '()))
+ (if (< i n)
+ (loop (+ i 1) (cons (pgsql-get-value result i 0) users))
+ (begin
+ (pgsql-clear result)
+ (reverse! users)))))))
+
+(define (db-new-user-account user-name first-names last-name password enabled?)
+ (if (known-user? user-name #t)
+ #f
+ (begin
+ (db-run-cmd "INSERT INTO users VALUES"
+ " (" (db-quote user-name)
+ ", " (db-quote first-names)
+ ", " (db-quote last-name)
+ ", " (db-quote (encrypt-password password))
+ ", " "FALSE"
+ ", " (if enabled? "TRUE" "FALSE")
+ ")")
+ #t)))
+
+(define (db-change-user-password user-name password)
+ (guarantee-known-user user-name)
+ (db-run-cmd "UPDATE users"
+ " SET password = " (db-quote (encrypt-password password))
+ " WHERE user_name = " (db-quote user-name)))
\f
-(define-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 (db-user-real-name user-name)
+ (let ((result
+ (db-run-query "SELECT first_names, last_name"
+ " FROM users"
+ " WHERE user_name = " (db-quote user-name))))
+ (if (> (pgsql-n-tuples result) 0)
+ (let ((first (pgsql-get-value result 0 0))
+ (last (pgsql-get-value result 0 1)))
+ (pgsql-clear result)
+ (values first last))
+ (begin
+ (pgsql-clear result)
+ (error "Unknown user:" user-name)
+ (values #f #f)))))
+
+(define (db-set-user-real-name user-name first-names last-name)
+ (guarantee-known-user user-name)
+ (db-run-cmd "UPDATE users"
+ " SET first_names = " (db-quote first-names)
+ ", last_name = " (db-quote last-name)
+ " WHERE user_name = " (db-quote user-name)))
+
+(define (db-user-enabled? user-name)
+ (get-user-flag user-name "enabled_p"))
+
+(define (db-user-administrator? user-name)
+ (get-user-flag user-name "administrator_p"))
+
+(define (db-set-user-enabled user-name value)
+ (set-user-flag user-name "enabled_p" value))
+
+(define (db-set-user-administrator user-name value)
+ (set-user-flag user-name "administrator_p" value))
(define (get-user-flag user-name flag-name)
(let ((result
(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 (db-valid-password? string)
+ (and (fix:>= (string-length string) 8)
+ (not (string-find-next-char-in-set string char-set:not-password))
+ (string-find-next-char-in-set string char-set:lower-case)
+ (string-find-next-char-in-set string char-set:upper-case)
+ (string-find-next-char-in-set string char-set:numeric)))
(define char-set:password
(char-set-union char-set:alphanumeric
(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 (db-generate-password)
+ (string-append (string (integer->char (+ (char->integer #\A) (random 26))))
+ (string (integer->char (+ (char->integer #\a) (random 26))))
+ (random-digit-string 6)))
(define (random-digit-string n-chars)
(string-pad-left (number->string (random (expt 10 n-chars))) n-chars #\0))
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: expenv.scm,v 1.1 2003/12/29 07:31:06 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.
+
+|#
+
+;;;; XHTML expander environment
+
+(define expander-environment
+ (the-environment))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: load.scm,v 1.1 2003/12/29 05:24:36 uid67408 Exp $
+$Id: load.scm,v 1.2 2003/12/29 07:31:10 uid67408 Exp $
Copyright 2003 Massachusetts Institute of Technology
|#
-;;;; XDOC/mod-lisp loader
+;;;; SSP/XDOC loader
-(load-option 'xml)
-(load-option 'postgresql)
-(load-option 'mime-codec)
+(load-option 'XML)
+(load-option 'POSTGRESQL)
+(load-option 'MIME-CODEC)
(with-working-directory-pathname (directory-pathname (current-load-pathname))
(lambda ()
- (load "xhtml-expander")
- (load "xhtml")
- (load "mod-lisp")
- (load "db")
- (load "matcher")
- (load "xdoc")
- (load "xmlrpc")))
\ No newline at end of file
+ (package/system-loader "ssp" '() 'QUERY)))
+(add-subsystem-identification! "SSP/XDOC" '(0 2))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: mod-lisp.scm,v 1.1 2003/12/29 05:24:43 uid67408 Exp $
+$Id: mod-lisp.scm,v 1.2 2003/12/29 07:31:14 uid67408 Exp $
Copyright 2003 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
-(define (start-server)
+(define (start-mod-lisp-server)
(start-server-internal 3000
(host-address-loopback)
(cond ((file-directory? "/web/www/") "/web/www/")
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
\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*))
+(define (http-request-entity)
+ (http-message-entity *current-request*))
+
+(define (http-request-method)
+ (http-message-method *current-request*))
+
+(define (http-request-url)
+ (http-message-url *current-request*))
+
+(define (http-request-header-bindings)
+ (http-message-headers *current-request*))
+
+(define (http-request-url-parameter-bindings)
+ (http-message-url-parameters *current-request*))
+
+(define (http-request-post-parameter-bindings)
+ (http-message-post-parameters *current-request*))
+
+(define (http-request-cookie-parameter-bindings)
+ (http-message-cookie-parameters *current-request*))
+
+(define (keyword-proc accessor name)
+ (lambda (keyword #!optional error?)
+ (let ((p (assq keyword (accessor *current-request*))))
+ (if p
+ (cdr p)
+ (begin
+ (if (if (default-object? error?) #f error?)
+ (error:bad-range-argument keyword name))
+ #f)))))
+
+(define http-request-header
+ (keyword-proc http-message-headers 'HTTP-REQUEST-HEADER))
+
+(define http-request-url-parameter
+ (keyword-proc http-message-url-parameters 'HTTP-REQUEST-URL-PARAMETER))
+
+(define http-request-post-parameter
+ (keyword-proc http-message-post-parameters 'HTTP-REQUEST-POST-PARAMETER))
+
+(define http-request-cookie-parameter
+ (keyword-proc http-message-cookie-parameters 'HTTP-REQUEST-COOKIE-PARAMETER))
+
+(define (http-request-post-parameter-multiple 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))))
\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 (http-request-pathname)
+ *current-pathname*)
+
+(define (server-root-dir)
+ *root-dir*)
+
+(define (http-response-header 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 (http-status-response code extra)
+ (guarantee-exact-nonnegative-integer code 'HTTP-STATUS-RESPONSE)
+ (guarantee-string extra 'HTTP-STATUS-RESPONSE)
+ (status-response! *current-response* code extra))
+
+(define (http-request-user-name)
+ (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
(if (not (eof-object? line))
(begin
(procedure line)
- (loop))))))
-
-(initialize-mime-extensions)
\ No newline at end of file
+ (loop))))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: ssp.pkg,v 1.1 2003/12/29 07:34:21 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.
+
+|#
+
+;;;; SSP: packaging
+
+(global-definitions "../runtime/runtime")
+(global-definitions "../xml/xml")
+
+(define-package (runtime ssp)
+ (parent (runtime)))
+
+(define-package (runtime ssp xhtml)
+ (files "xhtml")
+ (parent (runtime ssp))
+ (export (runtime ssp)
+ a
+ abbr
+ acronym
+ address
+ attributes
+ b
+ big
+ blockquote
+ body
+ br
+ button
+ caption
+ cite
+ code
+ col
+ colgroup
+ comment
+ convert-xhtml-string-value
+ dd
+ define-empty-element
+ define-standard-element
+ defn
+ del
+ dir
+ div
+ dl
+ dt
+ em
+ empty-element-constructor
+ flatten-xml-element-contents
+ form
+ h1
+ h2
+ h3
+ h4
+ h5
+ head
+ hr
+ href
+ html
+ http-equiv
+ i
+ id-def
+ id-ref
+ img
+ input
+ ins
+ kbd
+ li
+ link
+ listing
+ menu
+ meta
+ ol
+ optgroup
+ option
+ p
+ pre
+ q
+ rel-link
+ s
+ samp
+ script
+ select
+ small
+ span
+ standard-element-constructor
+ strike
+ strong
+ style
+ style-link
+ sub
+ sup
+ table
+ tbody
+ td
+ textarea
+ tfoot
+ th
+ thead
+ title
+ tr
+ tt
+ u
+ ul
+ var
+ xhtml-dtd
+ xhtml-iri)
+ (export (runtime ssp-expander-environment)
+ a
+ abbr
+ acronym
+ address
+ attributes
+ b
+ big
+ blockquote
+ body
+ br
+ button
+ caption
+ cite
+ code
+ col
+ colgroup
+ comment
+ dd
+ defn
+ del
+ dir
+ div
+ dl
+ dt
+ em
+ form
+ h1
+ h2
+ h3
+ h4
+ h5
+ head
+ hr
+ href
+ html
+ http-equiv
+ i
+ id-def
+ id-ref
+ img
+ input
+ ins
+ kbd
+ li
+ link
+ listing
+ menu
+ meta
+ ol
+ optgroup
+ option
+ p
+ pre
+ q
+ rel-link
+ s
+ samp
+ script
+ select
+ small
+ span
+ strike
+ strong
+ style
+ style-link
+ sub
+ sup
+ table
+ tbody
+ td
+ textarea
+ tfoot
+ th
+ thead
+ title
+ tr
+ tt
+ u
+ ul
+ var
+ xhtml-dtd
+ xhtml-iri))
+
+(define-package (runtime ssp xhtml-expander)
+ (files "xhtml-expander")
+ (parent (runtime ssp))
+ (export ()
+ expand-xhtml-directory
+ expand-xhtml-file
+ read/expand-xml-file)
+ (export (runtime ssp)
+ expander-eval
+ make-expansion-environment)
+ (export (runtime ssp-expander-environment)
+ emit
+ define-sabbr
+ get-sabbr))
+
+(define-package (runtime ssp-expander-environment)
+ (files "expenv")
+ (parent ())
+ (export (runtime ssp xhtml-expander)
+ expander-environment))
+
+(define-package (runtime ssp mod-lisp)
+ (files "mod-lisp")
+ (parent (runtime ssp))
+ (import (runtime debugger)
+ command/earlier-subproblem
+ command/print-subproblem
+ dstate/subproblem
+ make-initial-dstate)
+ (export ()
+ start-mod-lisp-server)
+ (export (runtime ssp)
+ define-mime-handler
+ define-subtree-handler
+ http-request-cookie-parameter
+ http-request-cookie-parameter-bindings
+ http-request-entity
+ http-request-header
+ http-request-header-bindings
+ http-request-method
+ http-request-pathname
+ http-request-post-parameter
+ http-request-post-parameter-bindings
+ http-request-post-parameter-multiple
+ http-request-url
+ http-request-url-parameter
+ http-request-url-parameter-bindings
+ http-request-user-name
+ http-response-header
+ http-status-response
+ mod-lisp-expander
+ server-root-dir)
+ (export (runtime ssp-expander-environment)
+ http-request-cookie-parameter
+ http-request-cookie-parameter-bindings
+ http-request-entity
+ http-request-header
+ http-request-header-bindings
+ http-request-method
+ http-request-pathname
+ http-request-post-parameter
+ http-request-post-parameter-bindings
+ http-request-post-parameter-multiple
+ http-request-url
+ http-request-url-parameter
+ http-request-url-parameter-bindings
+ http-request-user-name
+ http-response-header
+ http-status-response
+ server-root-dir)
+ (initialization (initialize-mime-extensions)))
+
+(define-package (runtime ssp xdoc)
+ (files "xdoc")
+ (parent (runtime ssp))
+ (export (runtime ssp)
+ int0-attribute
+ with-xdoc-expansion-context
+ xd:answer
+ xd:answer?
+ xd:boolean
+ xd:boolean?
+ xd:case
+ xd:case?
+ xd:check-action
+ xd:check-action?
+ xd:check-input
+ xd:check-input?
+ xd:check-inputs
+ xd:check-inputs?
+ xd:checkbox
+ xd:checkbox?
+ xd:choice
+ xd:choice?
+ xd:default
+ xd:default?
+ xd:due-date
+ xd:due-date?
+ xd:expected-value
+ xd:expected-value?
+ xd:explain
+ xd:explain?
+ xd:head
+ xd:head?
+ xd:hint
+ xd:hint?
+ xd:label
+ xd:label?
+ xd:menu
+ xd:menu?
+ xd:menuindex
+ xd:menuindex?
+ xd:menuitem
+ xd:menuitem?
+ xd:number
+ xd:number?
+ xd:problem
+ xd:problem?
+ xd:radio-buttons
+ xd:radio-buttons?
+ xd:radio-entry
+ xd:radio-entry?
+ xd:refer
+ xd:refer?
+ xd:submit-action
+ xd:submit-action?
+ xd:text
+ xd:text?
+ xd:true-false
+ xd:true-false?
+ xd:when
+ xd:when?
+ xd:xdoc
+ xd:xdoc?
+ xdoc-db-id
+ xdoc-output?)
+ (export (runtime ssp-expander-environment)
+ xd:answer
+ xd:answer?
+ xd:boolean
+ xd:boolean?
+ xd:case
+ xd:case?
+ xd:check-action
+ xd:check-action?
+ xd:check-input
+ xd:check-input?
+ xd:check-inputs
+ xd:check-inputs?
+ xd:checkbox
+ xd:checkbox?
+ xd:choice
+ xd:choice?
+ xd:default
+ xd:default?
+ xd:due-date
+ xd:due-date?
+ xd:expected-value
+ xd:expected-value?
+ xd:explain
+ xd:explain?
+ xd:head
+ xd:head?
+ xd:hint
+ xd:hint?
+ xd:label
+ xd:label?
+ xd:menu
+ xd:menu?
+ xd:menuindex
+ xd:menuindex?
+ xd:menuitem
+ xd:menuitem?
+ xd:number
+ xd:number?
+ xd:problem
+ xd:problem?
+ xd:radio-buttons
+ xd:radio-buttons?
+ xd:radio-entry
+ xd:radio-entry?
+ xd:refer
+ xd:refer?
+ xd:submit-action
+ xd:submit-action?
+ xd:text
+ xd:text?
+ xd:true-false
+ xd:true-false?
+ xd:when
+ xd:when?
+ xd:xdoc
+ xd:xdoc?
+ xdoc-due-date-attributes
+ xdoc-due-date-string
+ xdoc-part-number))
+
+(define-package (runtime ssp database-interface)
+ (files "db")
+ (parent (runtime ssp))
+ (export (runtime ssp)
+ close-database
+ with-database-connection)
+ (export (runtime ssp xdoc)
+ db-delete-persistent-value!
+ db-get-persistent-value
+ db-intern-persistent-value!
+ db-previously-saved-input
+ db-previously-saved-output
+ db-save-input!
+ db-save-output!
+ db-set-persistent-value!)
+ (export (runtime ssp-expander-environment)
+ db-change-user-password
+ db-clear-late-flag
+ db-clear-submitter
+ db-delete-persistent-value!
+ db-generate-password
+ db-get-persistent-value
+ db-get-ps-structure
+ db-get-saved-output
+ db-intern-persistent-value!
+ db-known-user?
+ db-known-users
+ db-late-submitters
+ db-new-user-account
+ db-problem-submitted?
+ db-ps-problem-names
+ db-quote
+ db-register-problem-set
+ db-registered-problem-sets
+ db-run-cmd
+ db-run-query
+ db-saved-submitters
+ db-set-persistent-value!
+ db-set-user-administrator
+ db-set-user-enabled
+ db-set-user-real-name
+ db-user-administrator?
+ db-user-enabled?
+ db-user-real-name
+ db-valid-password?))
+
+(define-package (runtime ssp xml-rpc)
+ (files "xmlrpc")
+ (parent (runtime ssp))
+ (export (runtime ssp)
+ rpc-elt:array
+ rpc-elt:base64
+ rpc-elt:boolean
+ rpc-elt:data
+ rpc-elt:date-time
+ rpc-elt:double
+ rpc-elt:fault
+ rpc-elt:i4
+ rpc-elt:int
+ rpc-elt:member
+ rpc-elt:method-call
+ rpc-elt:method-name
+ rpc-elt:method-response
+ rpc-elt:name
+ rpc-elt:param
+ rpc-elt:params
+ rpc-elt:string
+ rpc-elt:struct
+ rpc-elt:value)
+ (export (runtime ssp-expander-environment)
+ rpc-elt:array
+ rpc-elt:base64
+ rpc-elt:boolean
+ rpc-elt:data
+ rpc-elt:date-time
+ rpc-elt:double
+ rpc-elt:fault
+ rpc-elt:i4
+ rpc-elt:int
+ rpc-elt:member
+ rpc-elt:method-call
+ rpc-elt:method-name
+ rpc-elt:method-response
+ rpc-elt:name
+ rpc-elt:param
+ rpc-elt:params
+ rpc-elt:string
+ rpc-elt:struct
+ rpc-elt:value))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: xdoc.scm,v 1.1 2003/12/29 05:24:51 uid67408 Exp $
+$Id: xdoc.scm,v 1.2 2003/12/29 07:31:19 uid67408 Exp $
Copyright 2003 Massachusetts Institute of Technology
(define *xdoc-inputs*)
(define *xdoc-outputs*)
(define *trace-expansion-port* #f)
+(define db-name "six002x_spring04")
(define-mime-handler '(application/xdoc+xml "xdoc")
(lambda (pathname port)
0))))
(define (with-xdoc-expansion-context ps-number pathname procedure)
- (with-database-connection ps-number pathname
+ (with-database-connection db-name ps-number pathname
(lambda ()
(let ((environment (make-expansion-environment pathname)))
(fluid-let ((*xdoc-environment* environment)
(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)))
+(define (xdoc-part-number name)
+ (if (string-prefix? "xdoc_" name)
+ (string-tail name 5)
+ name))
\f
(define (ps-info elt)
(let ((no (find-attribute 'first-problem elt #f)))
submitter
*xdoc-late?*)))
(values correctness* submitter))))))
-\f
+
(define (current-input-status elt)
(let ((p (%current-input-status elt)))
(values (car p) (cdr p))))
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 (xdoc-due-date-attributes dt)
+ (attributes 'class
+ (string-append "xdoc-due-date "
+ (if (decoded-time-in-past? dt)
+ "xdoc-due-date-overdue"
+ "xdoc-due-date-on-time"))))
+
+(define (xdoc-due-date-string dt)
+ (let ((hour (decoded-time/hour dt))
+ (minute (decoded-time/minute dt)))
+ (string-append "Due: "
+ (day-of-week/long-string (decoded-time/day-of-week dt))
+ " "
+ (month/short-string (decoded-time/month dt))
+ ". "
+ (number->string (decoded-time/day dt))
+ " at "
+ (number->string
+ (cond ((> hour 12) (- hour 12))
+ ((> hour 0) hour)
+ (else 12)))
+ (if (> minute 0)
+ (string-append ":" (string-pad-left minute 2 #\0))
+ "")
+ " "
+ (if (> hour 12) "PM" "AM"))))
(define (due-date-in-past?)
(let ((elt (find-named-child 'due-date *xdoc-root* #f)))
(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
+(define-syntax define-element
+ (sc-macro-transformer
+ (lambda (form env)
+ env
+ (let ((local (cadr form))
+ (content-type (caddr form))
+ (elt-type (cadddr form)))
+ (let ((qname (symbol-append 'xd: local)))
+ `(BEGIN
+ (DEFINE ,qname
+ (,(if (eq? content-type 'empty)
+ 'EMPTY-ELEMENT-CONSTRUCTOR
+ 'STANDARD-ELEMENT-CONSTRUCTOR)
+ ',qname
+ XDOC-IRI))
+ (DEFINE ,(symbol-append qname '?)
+ (LET ((NAME (MAKE-XML-NAME ',qname XDOC-IRI)))
+ (LAMBDA (OBJECT)
+ (AND (XML-ELEMENT? OBJECT)
+ (XML-NAME=? (XML-ELEMENT-NAME OBJECT) NAME)))))
+ (HASH-TABLE/PUT! XDOC-CONTENT-TYPES ',local ',content-type)
+ (HASH-TABLE/PUT! XDOC-ELEMENT-TYPES ',local ',elt-type)))))))
+
+(define-element xdoc mixed top-level-container)
+(define-element head mixed internal)
+(define-element 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 (xd:true-false . keyword-list)
+ (xd:radio-buttons (apply attributes keyword-list)
+ (xd:radio-entry (attributes 'value 'true) "True")
+ (xd:radio-entry (attributes 'value 'false) "False")))
+
+(define (xd:true-false? object)
+ (and (xd:radio-buttons? object)
+ (let ((entries (xml-element-contents object)))
+ (and (fix:= (length entries) 2)
+ (let ((v1 (find-attribute 'value (car entries) #t))
+ (v2 (find-attribute 'value (cadr entries) #t)))
+ (or (and (string=? v1 "true") (string=? v2 "false"))
+ (and (string=? v1 "false") (string=? v2 "true"))))))))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: xhtml-expander.scm,v 1.1 2003/12/29 05:24:59 uid67408 Exp $
+$Id: xhtml-expander.scm,v 1.2 2003/12/29 07:31:22 uid67408 Exp $
Copyright 2002,2003 Massachusetts Institute of Technology
;;;; 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-directory directory)
+ (for-each expand-xhtml-file (directory-read directory)))
(define (expand-xhtml-file input #!optional output)
(let ((document
(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)
(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)))))
#| -*-Scheme-*-
-$Id: xmlrpc.scm,v 1.1 2003/12/29 05:25:02 uid67408 Exp $
+$Id: xmlrpc.scm,v 1.2 2003/12/29 07:31:26 uid67408 Exp $
Copyright 2003 Massachusetts Institute of Technology
;; Probably not right -- formatting issues
(rpc-elt:double (number->string object)))
((boolean? object)
- (rpc-elt:boolean? (if object "1" "0")))
+ (rpc-elt:boolean (if object "1" "0")))
((string? object)
(if (utf8-string-valid? object)
(rpc-elt:string object)
projects / mit-scheme.git / commitdiff