;;;
;;; Time-stamp: <06/05/17 15:55:46 noel>
;;;
;;; 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:

(module instaweb mzscheme

  (require (lib "etc.ss")
           (lib "web-server.ss" "web-server")
           (lib "configuration.ss" "web-server")
           (lib "plt-match.ss")
           (lib "file.ss"))
  
  (provide instaweb)

  ;; instaweb : string [integer] [(U string #f)] -> void
  (define instaweb
    (opt-lambda (servlet [port 80] [ip-address #f])
      (setup-server servlet port)
      (run-server servlet port ip-address)
      (teardown-server servlet)))

  
  (define config-file-name "web-server-config.txt")

  ;; make-directory-tree : (tree-of string) -> void
  (define (make-directory-tree tree)
    (define (tree-fold seed tree)
      (define (list->path head rest)
        (apply build-path (reverse (cons head rest))))
      (match tree
        [(? string? here)
         (make-directory* (list->path here seed))]
        [(list) (void)]
        [`(,(? string? head) (,children ...) . ,rest)
         (make-directory* (list->path head seed))
         (tree-fold (cons head seed) children)
         (tree-fold seed rest)]
        [`(,(? string? here) . ,rest)
         (make-directory* (list->path here seed))
         (tree-fold seed rest)]))
    (tree-fold null tree))

  (define (maybe-copy-file src dest)
    (unless (file-exists? dest)
      (copy-file src dest)))
  
  ;; make-directories : () -> void
  (define (make-directories)
    (make-directory-tree
     '("default-web-root" ("servlets" "conf" "htdocs"))))

  ;; copy-mime-types : () -> void
  (define (copy-mime-types)
    (maybe-copy-file
     (build-path (this-expression-source-directory) "mime.types")
     (build-path "default-web-root" "mime.types")))

  ;; copy-not-found : () -> void
  (define (copy-not-found)
    (maybe-copy-file
     (build-path (this-expression-source-directory)
                 "not-found.html")
     (build-path "default-web-root" "conf" "not-found.html")))
  
  ;; make-configuration : string integer -> void
  (define (make-configuration servlet port)
    (with-output-to-file config-file-name
      (lambda ()
        (write
         `((port ,port)
           (max-waiting 40)
           (initial-connection-timeout 30)
           (default-host-table
             (host-table
              (default-indices "index.html" "index.htm")
              (log-format parenthesized-default)
              (messages
               (servlet-message "servlet-error.html")
               (authentication-message "forbidden.html")
               (servlets-refreshed "servlet-refresh.html")
               (passwords-refreshed "passwords-refresh.html")
               (file-not-found-message "not-found.html")
               (protocol-message "protocol-error.html")
               (collect-garbage "collect-garbage.html"))
              (timeouts
               (default-servlet-timeout 30)
               (password-connection-timeout 300)
               (servlet-connection-timeout 86400)
               (file-per-byte-connection-timeout 1/20)
               (file-base-connection-timeout 30))
              (paths
               (configuration-root "conf")
               (host-root "default-web-root")
               (log-file-path "log")
               (file-root "htdocs")
               (servlet-root ".")
               (mime-types "mime.types")
               (password-authentication "passwords"))))
           (virtual-host-table))))
      'replace))

  ;; delete-configuration : () -> void
  (define (delete-configuration)
    (when (file-exists? (string->path config-file-name))
      (delete-file (string->path config-file-name))))

  (define (copy-servlet servlet)
    (delete-servlet servlet)
    (copy-file (string->path servlet)
               (string->path
                    (string-append "default-web-root/servlets/" servlet))))

  (define (delete-servlet servlet)
    (when (file-exists? (string->path
                         (string-append "default-web-root/servlets/" servlet)))
      (delete-file (string->path
                    (string-append "default-web-root/servlets/" servlet)))))

  ;; setup-server : string integer -> void
  (define (setup-server servlet port)
    (make-directories)
    (make-configuration servlet port)
    (copy-servlet servlet)
    (copy-mime-types)
    (copy-not-found))

  ;; run-server : string integer (U string #f) -> void
  (define (run-server servlet port ip-address)
    (define (display-usage)
      (printf "Web server started on port ~a\n" port)
      (printf "Visit URL http://localhost:~a/servlets/~a\n" port servlet)
      (printf "Type stop to stop the server and exit\n")
      (printf "Type restart to restart the server\n"))
    (define (server-loop config stop-server)
      (display-usage)
      (let loop ((cmd (read)))
        (case cmd
          ((stop) (stop-server))
          ((restart)
           (stop-server)
           (copy-servlet servlet)
           (server-loop config (serve config port ip-address)))
          (else (printf "Don't know what to do with ~a.  Try again.\n" cmd)
                (loop (read))))))
    (let ((config
           (load-configuration (string->path config-file-name))))
      (server-loop config (serve config))))

  ;; teardown-server : string -> void
  (define (teardown-server servlet)
    (delete-servlet servlet)
    (delete-configuration))

  ;; This is kept around in case we support cleanup at some
  ;; point in the future
  ;;
  ;; delete-directories : () -> void
  (define (delete-directories)
    (when (directory-exists?
           (string->path "default-web-root/servlets"))
      (delete-directory "default-web-root/servlets"))
    (when (directory-exists? (string->path "default-web-root"))
      (delete-directory "default-web-root")))
  
  )