; Validation code for the HTTP transaction module http.scm
;
; IMPORT
; Functions declared in files util.scm, input-parse.scm, and mime.scm
; SRFI-12 and my standard prelude are assumed: myenv*.scm and srfi-12.scm
;
; See the Makefile for the exact command-line to run this code. For example,
; to interpret this code using Bigloo, the following Makefile rule is used:
;
; check-http-bigloo:
;	echo '(module test (include "myenv-bigloo.scm")
;	      (include "srfi-12.scm") (include "util.scm")
;	      (include "input-parse.scm") (include "http.scm")
;	      (include "mime.scm") (include "vhttp.scm")) ' \
;	| bigloo -i -no-hello --
;
; $Id: vhttp.scm,v 1.5 2004/04/29 19:59:24 oleg Exp oleg $

; This function is imported into the input-parse.scm module
(define (parser-error port msg . specializing-msgs)
  (apply error (cons msg specializing-msgs)))

; The handler to process web server responses
(define (response-handler resp-code resp-headers http-port)
  (cerr "Returned resp-code " resp-code nl)
  (cerr "Headers: " resp-headers nl)
  (cerr nl "The rest of the response follows" nl
	(lambda (port) 
	  (let ((chunk-size 1024))
	    (do ((chunk (read-string chunk-size http-port)
			(read-string chunk-size http-port)))
		((or (eof-object? chunk) (string-null? chunk)))
	      (display chunk port))))
	nl "---Done---" nl)
  resp-code) ; return the response code

; The test driver
; Expected-code is either a number or a symbol 'FAILURE
(define-macro (test form expected-code)
  (let ((ret-code (gensym)))
    `(begin
       (cerr nl nl ">>> Form: " ',form nl)
       (let ((,ret-code
	      (handle-exceptions
	       exc (begin
		     (cerr "Caught exception: " exc nl)
		     'FAILURE)
	       ,form)))
	 (cerr "Finished with the return code: " ,ret-code nl)
	 (assert (equal? ,ret-code ,expected-code))))))

					; UNSUPPORTED-SCHEMA
(test
 (http-transaction "GET" "httpXX://localhost/" '() response-handler)
 'FAILURE)


					; BAD-REQ-URL
(test
 (http-transaction "GET" "localhost" '() response-handler)
 'FAILURE)

					; Non-existent host
(test
 (http-transaction "GET" "http://xxxxx/" '() response-handler)
 'FAILURE)


					; 501: Method not implemented
(test
 (http-transaction "XXX" "http://localhost/~oleg/" '() response-handler)
 501)

(test
 (http-transaction "GET" "http://xxxx/zzz" '((http-proxy . "localhost"))
		   response-handler)
 404)

(test
 (http-transaction "GET" "http://www.metnet.navy.mil/Metcast/not-found" '()
		   response-handler)
 404)
 
					; 405: Method not allowed
(test
 (http-transaction "POST" "http://localhost/~oleg/" '() response-handler)
 405)

					; 304: Not modified
(test
 (http-transaction "GET" "http://localhost/~oleg/"
		   '((http-req ("if-modified-since" .
				"Thu, 09 Aug 2001 00:54:02 GMT")))
		   response-handler)
 304)

					; 411: length required
(test
 (http-transaction "POST" "http://www.metnet.navy.mil/cgi-bin/oleg/server"
		   '() response-handler)
 411)

					; real request
(test
 (let ((mbl-req '(Req (bounding-box 90 -180 -90 180)
		      (st_constraint (call_id "KMRY"))
		      (products (METAR)))))
   (http-transaction "POST" "http://www.metnet.navy.mil/cgi-bin/oleg/server"
		     `((http-req . ,(lambda (http-port)
				      (let ((req-string (with-output-to-string
						(lambda () (write mbl-req)))))
			 (for-each (lambda (str) (display str http-port))
			    `("Content-length: "
			      ,(string-length req-string) "\r\n"
			      "Content-type: text/x-mbl\r\n"
			      "\r\n"	; end-of-headers
			      ,req-string)))))
		     )
		   response-handler))
 200)

(test			       ; This must give redirection
 (http-transaction "GET" "http://www.pobox.com:80/~oleg" '() 
		   response-handler)
 302)


(cerr nl nl "All tests passed" nl)