(import (chicken condition) (chicken format) (chicken io)
        (chicken process-context) (chicken process-context posix)
        (chicken tcp) (chicken process) (chicken file posix)
        uri-common intarweb srfi-18)

(cond-expand
  (chicken-6)
  (else (define read-bytevector read-string)))

(server-port (string->number
               (or (get-environment-variable "SPIFFY_TEST_PORT") "8080")))

(define (check-port)
  (let ((listener #f)
	(msg (sprintf "Checking port ~A is available" (server-port))))
    (handle-exceptions exn (void)
		       (set! listener (tcp-listen (server-port))))
    (test-assert msg (tcp-listener? listener))
    (tcp-close listener)))

(define spiffy-pid #f)

(define (can-connect?)
  (handle-exceptions exn #f
    (receive (in out)
        (tcp-connect "127.0.0.1" (server-port))
      (close-input-port in)
      (close-output-port out)
      #t)))

(define (wait-for-spiffy times)
  (if (zero? times)
      #f
      (begin (thread-sleep! 1) (or (can-connect?) (wait-for-spiffy (sub1 times))))))

(define NOT-FOUND "file not found")

(define (send-string/code code reason string)
  (current-response
   (update-response (current-response)
                    code: code reason: reason))
  (write-logged-response)
  (display string (response-port (current-response))))

(define response-error? #f)

(define (start-spiffy)
  (check-port)
  (set! spiffy-pid
	(process-fork
         (lambda ()
           (parameterize ((root-path "./testweb")
                          (error-log (get-environment-variable "SPIFFY_ERROR_LOG"))
                          (handle-not-found
                           (lambda (p)
                             (send-string/code 404 "Not found" NOT-FOUND)))
                          (handle-exception
                           (lambda (exn chain)
                             (let ((m ((condition-property-accessor 'exn 'message) exn))
                                   (a ((condition-property-accessor 'exn 'arguments) exn)))
                               (log-to (error-log) (build-error-message exn chain #t))
                               (set! response-error? #t)
                               (send-string/code 500 "Internal server error"
                                                 (if (and a (not (null? a)))
                                                     (sprintf "~A ~A" m a)
                                                     m))))))
             (start-server)))))
  (on-exit (lambda _ (process-signal spiffy-pid)))
  (test-assert "Spiffy responds in 3 seconds" (wait-for-spiffy 3))
  (void))

;;;; test tools

(define (fetch-file file host #!key (send-headers `((host (,host . ,(server-port))))) (get-headers #f) (version '(1 0)) (method 'GET) (absolute-uri #t) (binary #f))
  (set! response-error? #f)
  (let ((uri (uri-reference (if absolute-uri
                                (sprintf "http://~A:~A~A" host (server-port) file)
                                file))))
    (receive (in out)
      (tcp-connect "127.0.0.1" (server-port))
      (let* ((req-headers (headers send-headers))
             (req (make-request method: method uri: uri
                                major: (car version) minor: (cadr version)
                                headers: req-headers port: out)))
        (write-request req)
        (let* ((resp (read-response in))
               (str ((if binary read-bytevector read-string)
                     (header-value 'content-length (response-headers resp)) in)))
          (close-output-port out)
          (close-input-port in)
          (if get-headers
              (response-headers resp)
              (list (response-code resp) str)))))))

(define-syntax test-response
  (syntax-rules ()
   ((_ ?text (?code-expected ?contents-expected) ?args ...)
    (test ?text (list ?code-expected ?contents-expected) (fetch-file ?args ...)))
   ((_ ?text ?code-expected ?args ...)
    (test ?text ?code-expected (car (fetch-file ?args ...))))))

(define-syntax test-binary-response
  (syntax-rules ()
   ((_ ?text (?code-expected ?contents-expected) ?args ...)
    (test ?text (list ?code-expected ?contents-expected) (fetch-file ?args ... binary: #t)))
   ((_ ?text ?code-expected ?args ...)
    (test ?text ?code-expected (car (fetch-file ?args ... binary: #t))))))

(define-syntax test-header
  (syntax-rules ()
    ((_ ?text ?header-name (?header-values ...) ?args ...)
     (test ?text `(?header-values ...)
           (header-values `?header-name
                          (fetch-file ?args ... get-headers: #t))))))

;; Create an uri for this test server, which is needed because its
;; port may be overridden.
(define (testserver-uri str)
  (let ((ref (uri-reference str)))
    (update-uri ref port: (server-port))))