;;;
;;; Time-stamp: <2007-11-23 12:23:10 us>
;;;
;;; Copyright (C) 2005 by Noel Welsh.
;;;

;;; This library is free software; you can redistribute it
;;; and/or modify it under the terms of the GNU Lesser
;;; General Public License as published by the Free Software
;;; Foundation; either version 2.1 of the License, or (at
;;; your option) any later version.

;;; This library 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 Lesser General Public
;;; License for more details.

;;; You should have received a copy of the GNU Lesser
;;; General Public License along with this library; if not,
;;; write to the Free Software Foundation, Inc., 59 Temple
;;; Place, Suite 330, Boston, MA 02111-1307 USA

;;; Author: Noel Welsh <noelwelsh@yahoo.com>
;;
;;
;; Commentary:

#lang scheme/base

(require mzlib/etc
         web-server/web-server)

(require (file "defaults.ss")
         (prefix-in dispatcher: (file "dispatcher.ss")))

(provide instaweb
         instaweb-here
         (rename-out (dispatcher:make make-dispatcher))
         run-server
         console-loop)

;; syntax instaweb-here : servlet [port] [ip-address]
(define-syntax instaweb-here
  (syntax-rules ()
    [(instaweb/here arg ...)
     (parameterize [(current-directory (this-expression-source-directory))]
       (instaweb arg ...))]))

;; instaweb : [#:port              integer]
;;            [#listen-ip          (U string #f)]
;;            [#:servlet-path      (U path string)]
;;            [#:htdocs-path       (listof (U path string))]
;;            [#:mime-types-path   path]
;;            [#:servlet-namespace (listof require-spec)]
;;   ->
;;            void
(define (instaweb #:port              [port              8765]
                  #:listen-ip         [listen-ip         "127.0.0.1"]
                  #:servlet-path      [servlet-path      default-servlet-path]
                  #:htdocs-path       [htdocs-path       default-htdocs-path]
                  #:mime-types-path   [mime-types-path   default-mime-types-path]
                  #:servlet-namespace [servlet-namespace default-servlet-namespace])
    (define (run-server-thunk)
      (run-server port 
                  listen-ip
                  #:servlet-path      servlet-path
                  #:htdocs-path       htdocs-path
                  #:mime-types-path   mime-types-path
                  #:servlet-namespace servlet-namespace))
    (parameterize
        ([print-hash-table #t]
         [print-struct #t]
         [error-print-width 1024]
         [error-print-context-length 50])
      (console-loop run-server-thunk)))

;;; Utility functions ---------------------------------------------------

;; run-server : integer
;;              (U string #f)
;;              [#:servlet-path      (U path string)]
;;              [#:htdocs-path       (listof (U path string))]
;;              [#:mime-types-path   path]
;;              [#:servlet-namespace (listof require-spec)]
;;   ->
;;              stop-server-thunk
(define (run-server port listen-ip 
                    #:servlet-path      servlet-path
                    #:htdocs-path       htdocs-path
                    #:mime-types-path   mime-types-path
                    #:servlet-namespace servlet-namespace)
  (define dispatch
    (dispatcher:make #:servlet-path      servlet-path
                     #:htdocs-path       htdocs-path
                     #:mime-types-path   mime-types-path
                     #:servlet-namespace servlet-namespace))
  (begin0 (serve #:dispatch  dispatch
                 #:port      port
                 #:listen-ip listen-ip)
          (printf "Web server started on port ~a\n" port)
          (printf "Listening on IP address: ~a\n"
                  (if listen-ip listen-ip "all addresses"))))

;; console-loop : ( -> stop-server-thunk) -> void
(define (console-loop run-server)
  (define (display-usage)
    (printf "Type stop to stop the server and exit\n")
    (printf "Type restart to restart the server\n"))
  (let ([stop-server (run-server)])
    (display-usage)
    (let loop ([cmd (read)])
      (cond
        [(eof-object? cmd)
         (printf "Instaweb: Received EOF from input port.  Will not read further\n")
         (thread-wait (current-thread))]
        [(eq? cmd 'stop) (stop-server)]
        [(eq? cmd 'restart)
         (stop-server)
         (console-loop run-server)]
        [else (printf "Don't know what to do with ~a.  Try again.\n" cmd)
              (display-usage)
              (loop (read))]))))