adapt seval-handler to new response philosophy

FIXME: problems with input port in POST request

scheme/httpd/seval.scm

@@ -38,6 +38,15 @@
   (syntax-rules ()
     ((do/timeout secs body ...) (do/timeout* secs (lambda () body ...)))))
 
+(define-condition-type 'seval-error '())
+(define seval-error? (condition-predicate 'seval-error))
+
+(define-condition-type 'seval-no-content-length-error '(seval-error))
+(define seval-no-content-length-error? 
+  (condition-predicate 'seval-no-content-length-error))
+
+(define-condition-type 'seval-no-program '(seval-error))
+(define seval-no-program? (condition-predicate 'seval-no-program))
 
 ;;; The path handler for seval ops.
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -46,37 +55,65 @@
   (let ((request-method (request:method req)))
     (cond 
      ((string=? request-method "POST")	; Could do others also.
+      (call-with-current-continuation
+       (lambda (exit)
+	 (begin
+	   (with-handler
+	    (lambda (condition more)
+	      (exit
+	       (cond
+		((seval-no-content-length-error? condition)
+		 (make-http-error-response 
+		  http-status/bad-request req
+		  "No `Content-length:' field in POST request."))
+		((seval-no-program?  condition)
+		 (make-http-error-response http-status/bad-request req
+					   "No program in entity body."))
+		(else
+		 (make-http-error-response 
+		  http-status/internal-error req
+		  "Unknown error while evaluating seval-expression."
+		  condition)))))
+	    (lambda ()
+	      (seval path req)))))))
      
-      (let ((modern-protocol? (not (v0.9-request? req))))
-	(if modern-protocol?
-	    (begin
-	      (begin-http-header #t 200)
-	      (write-string "Content-type: text/html\r\n\r\n")))
-	(with-tag #t HEAD ()
-		  (newline)
-		  (emit-title #t "Scheme program output"))
-	(newline))
+     (else
+      (make-http-error-response http-status/method-not-allowed req)))))
 
-      (with-tag #t BODY ()
-		(newline)
-		(let ((sexp (read-request-sexp req)))
-		  (do/timeout 
-		   10
-		   (receive vals
-			    ;; Do the computation.
-			    (begin (emit-header #t 2 "Output from execution")
-				   (newline)
-				   (with-tag #t PRE ()
-					     (newline)
-					     (force-output)	; In case we're gunned down.
-					     (eval-safely sexp)))
+(define (seval path req)
+  (let ((sexp (read-request-sexp req)))
+    (http-syslog (syslog-level debug) "read sexp: ~a" sexp)
+    (make-response
+     http-status/ok
+     (status-code->text http-status/ok)
+     (time)
+     "text/html"
+     '()
+     (make-writer-body
+      (lambda (port options)
+	(with-tag port HEAD ()
+	  (newline port)
+	  (emit-title port "Scheme program output"))
+	(newline port)
 	
-			    ;; Pretty-print the returned value(s).
-			    (emit-header #t 2 "Return value(s)")
-			    (with-tag #t PRE ()
-				      (for-each p vals)))))))
+	(with-tag port BODY ()
+	  (newline port)
+	  (do/timeout 
+	   10
+	   (receive vals
+	       ;; Do the computation.
+	       (begin (emit-header port 2 "Output from execution")
+		      (newline port)
+		      (with-tag port PRE ()
+			(newline port)
+			(force-output port); In case we're gunned down.
+			(eval-safely sexp)))
 	     
-      (else (http-error http-status/method-not-allowed #f req)))))
+	     ;; Pretty-print the returned value(s).
+	     (emit-header port 2 "Return value(s)")
+	     (with-tag port PRE ()
+	       (for-each (lambda (val) (p val port))
+			 vals))))))))))
 
 
 ;;; Read an HTTP request entity body from stdin. The Content-length:
@@ -97,11 +134,11 @@
 						(string-length cl-str)))
 		     0)) ; All whitespace?? -- WTF.
 	     (qs (read-string cl))			; Read in CL chars,
+	     ;; FIXME where is the input port?
 	     (q (parse-html-form-query qs))		; and parse them up.
 	     (s (cond ((assoc "program" q) => cdr)
-		      (else (error "No program in entity body.")))))
+		      (else (signal 'seval-no-program)))))
 	(http-syslog (syslog-level debug)
-		     "Seval sexp:~%~s~%" s)
+		     "Seval sexp: ~s" s)
 	(read (make-string-input-port s)))))
-   (else (http-error http-status/bad-request req
-		     "No Content-length: field in POST request."))))
+   (else (signal 'seval-no-content-length-error))))

scheme/packages.scm

@@ -448,6 +448,7 @@
   (open receiving	; MV return (RECEIVE and VALUES)
 	scsh-utilities	; index
 	srfi-13
+	srfi-1		; fold
 	let-opt         ; let-optionals
 	crlf-io		; read-crlf-line
 	ascii		; ascii->char
@@ -804,6 +805,7 @@
 	srfi-13			; STRING-SKIP
 	rfc822
 	toothless-eval			; EVAL-SAFELY
+	conditions signals
 	handle				; IGNORE-ERROR
 	parse-html-forms		; PARSE-HTML-FORM-QUERY
 	threads				; SLEEP