;; $Id: httpd.scm,v 1.18 2004/01/28 11:13:05 hip Exp $
(use gauche.net)
(use gauche.selector)
(use file.util)
(use gauche.time)

;; TODO
;; - make dispatcher multi-threaded
;; - add counters, generate statistics + timings, preferably using aspects
;; - create a plug-in architecture with handlers that are called
;;   based on file-type (.html, .png) or request-type (CGI, directory listing)
;;   register plug-ins with a handler table, this table is used to dispatch
;;   a request to a handler
;; - figure out how to have the server socket listen on a specific address,
;;   e.g. 127.0.0.1:8001, instead of 0.0.0.0:8001
;; - restructure http-server so that functions can be redefined at run-time:
;;   eases development, no need to restart the server all the time. Write
;;   messages to a log file, and start a REP-loop after server startup.
;; - ignore SIGPIPE signals??? (thttpd does this)

;; SEE http.scm in gauche/modules for a HTTP 1.1 client

;; BUG when terminating a long download from inside the browser (e.g.
;; the jargon file): *** oops: write failed on #<oport (socket output
;; #<socket (connect "127.0.0.1:33571")>) 0x872e280>: Connection reset by peer

;; TODO use text.html-lite and text.tree for HTML generation

;; TODO study emacs elserv: has a lot of interesting stuff, including
;; keep-alive functionality

;; TODO study sawfish-client: uses a unix socket to allow
;; sawfish-client to connect to the running lisp system

;; TODO study stklos function 'uri-parse':
;; (uri-parse "http://google.com")
;;   => (:scheme "http" :host "google.com" :port 80 :path "/"
;;       :query "" :fragment "")
;; (uri-parse "http://stklos.net:8080/a/file?x=1;y=2#end")
;;   => (:scheme "http" :host "stklos.net" :port 8080
;;       :path "/a/file" :query "x=1;y=2" :fragment "end")

(define httpd-version "0.1")
(define httpd-host "localhost")
(define httpd-port 8001)
(define document-root (resolve-path "~/lib/html"))

(define *message-port* (standard-output-port))

(define (message format-string . args)
  (apply (pa$ format *message-port* format-string) args))

(define-syntax unit-test
  (syntax-rules (=>)
    ((unit-test expr)
     (unit-test expr => #t))
    ((unit-test expr => result)
     (unless (equal? expr result)
       (message "failed: ~a => ~a, expected ~a\n" 'expr expr result)))))

(define (file->string-list file . opts)
  (apply call-with-input-file file (pa$ port->list read-line) opts))

(define (rounded-number->string x . digits-of-precision)
  (if (null? digits-of-precision)
      (number->string (inexact->exact (round x)))
      (let* ((digits (car digits-of-precision))
             (factor (expt 10.0 digits))
             (n (abs (inexact->exact (round (* x factor)))))
             (s (number->string n))
             (l (string-length s))
             (rs (if (< n factor)
                     (string-append "0."
                                    (make-string (- digits l) #\0)
                                    s)
                     (string-append (substring s 0 (- l digits))
                                    "."
                                    (substring s (- l digits) l)))))
        (if (< x 0) (string-append "-" rs) rs))))

(define (make-mime-mapper)
  (let ((mime-map ())
        (rawtext (file->string-list "/etc/mime.types")))
    (dolist (line rawtext)
      (rxmatch-case line
        (#/^#/ (#f) 'ok)
        (#/^$/ (#f) 'ok)
        (#/([^\s]*?)\s+(.+)$/ (#f type exts)
           (dolist (ext (string-split exts " "))
             (set! mime-map (cons
                             (cons
                              (string->symbol ext)
                              type)
                             mime-map))))
        (#/(.*)/ (type) 'ok)
        (else
         (message "make-mime-mapper: stymied: ~a\n" line))))

    (lambda (ext)
      (let ((rec (assoc ext mime-map)))
        (and rec (cdr rec))))))

(define (make-statistics-counter)
  (let ((hits 0) (misses 0) (bytes 0) (time 0))
    (define (hit)
      (inc! hits))
    (define (miss)
      (inc! misses))
    (define (bytes-sent new-bytes)
      (set! bytes (+ bytes new-bytes)))
    (define (time-used new-time)
      (set! time (+ time new-time)))
    (define (print-stats)
      (message "(requests ~d hits ~d misses ~d)\n" (+ hits misses) hits misses)
      (message "(bytes-sent ~d time-used ~a throughput ~a bytes/s)\n"
               bytes
               (rounded-number->string time 3)
               (rounded-number->string (if (= time 0) 0 (/ bytes time)))))
    (lambda args
      (apply
       (case (car args)
         ((hit) hit)
         ((miss) miss)
         ((bytes-sent) bytes-sent)
         ((time-used) time-used)
         ((print) print-stats))
       (cdr args)))))

(define (full-path filename)
  ;; BUG /../foo allows retrieval outside document-root
  (string-append document-root filename))

(define (filename-parts filename)
  ;; TODO return a list of constituent parts (or a closure)
  (list full-path basename extension parameters))

(define (send-file filename output-port)
  (let ((counter (make <real-time-counter>)))
    (with-time-counter
     counter
     (call-with-input-file filename
       (lambda (port)
         ;; todo look at the :unit and :size keywords to copy-port
         (copy-port port output-port))))
    (*statistics* 'time-used (time-counter-value counter))
    (*statistics* 'bytes-sent (file-size filename))))

(define (handle-file filename output)
  ;; TODO RFC 2046 specifies that unknown file types should have
  ;; type text/plain when it's a known charset, and
  ;; application/octet-stream when it's a unknown charset.
  (let ((mime-type
         (rxmatch-if (rxmatch #/.*\.([^.]+)/ filename) (#f extension)
           (or (*mime-mapper* (string->symbol extension))
               "text/plain")
           "text/plain")))
    (format output "HTTP/1.0 200 OK\nContent-type: ~a\n\n" mime-type)
    (send-file (full-path filename) output)))

(define (handle-directory filename output)
  (display (header) output)
  (format output "<h1>directory listing of '~a'</h1>\n" filename)
  (format output "<p>~a\n"
          (string-join
           (map
            (lambda (name)
              (format "<a href=\"~a/~a\">~a</a>"
                      filename name name))
            (directory-list (full-path filename) :children? #t))
           "<br>\n")))

(define (handle-error request output)
  (message "(404 ~s)\n" (cdr (assoc 'GET request)))
  (format output
          (string-append
           "HTTP/1.0 404 Not found\nContent-type: text/html\n\n"
           "<h1>404 Not Found</h1>\n"
           "request: ~s\n")
          request))

(define (server-script? filename)
  (let* ((name (car (string-split filename "?")))
         (len (string-length name)))
    (string=? ".ss" (substring name (- len 3) len))))

;; IDEA: don't use html-pages anywhere, just let scheme modules define
;; all pages. Module are registered with the http-server, and tell it
;; which top level domains they serve. The root module handles all
;; requests not claimed by other modules (/ ,/index, 404's). If a
;; modules for instance claims to handle /webapp, all requests to
;; /webapp and urls beneath that location are sent to that module,
;; e.g. /webapp/index/chapter-2. A resolver function maps request urls
;; to registered modules.
(when #f
  (use text.tree)
  (use text.html-lite)

  (define-server-module root
    (define (index)
      (html-doctype)
      (tree->string ;; (write-tree port)
       (html:html
        (html:head (html:title "index"))
        (html:body
         (html:h1 "index")
         (html:p "lalala")
         (html:p "hopsasa")))))
  
    (define (just-a-file)
      "display something from the filesystem"
      (display-file "/foo/bar.scm"))

    (define (serve-old-page-based-website)
      "serve old style websites, e.g. a downloaded SICP copy"
      (resolve-url-in-the-filesystem-starting-from "/sicp"))

    ;; return the url->function mapping
    '(("/" index)
      ("/arfle.txt" just-a-file)
      ("/sicp" serve-old-page-based-website)
      ("/inline" (lambda () 'inline-stuff))))

  '(define-macro (define-server-module name . body)
    (define-module ,(string-append "server-module-" name))
    (for-each func in (body except last form)
              define the func in the new module)
    (register the last form containing the url->function map with the server)))

;; FIXME once a server-script defines something in jail, it stays
;; around. Subsequent scripts could abuse this 'feature'. Find a way
;; to purge the jail after execution of each server-script.
(define-module jail)

(define (handle-server-script filename output)
  (let* ((flist (string-split filename "?"))
         (filename (car flist))
         (arguments (cdr flist)))
    (message "filename: ~a, args: ~a\n" filename arguments)
    (load (full-path filename) :environment (find-module 'jail))
    (with-output-to-port output
      (lambda () (with-module jail
                   (apply run arguments))))))

;; (define (handle-server-script/INSECURE filename output)
;;   (let* ((flist (string-split filename "?"))
;;          (filename (car flist))
;;          (arguments (cdr flist)))
;;     (message "filename: ~a, args: ~a\n" filename arguments)
;;     (load (full-path filename))
;;     (with-output-to-port output
;;       (lambda () (apply run arguments)))))

(define (dispatch client input output)
  ;;(print "handler enter")
  (let ((request (parse-request input)))
    ;;(format #t "~s\n" request)
    (cond
     ((null? request)
      (message "*** null request ***\n"))
     ((assoc 'GET request) =>
      (lambda (c)
        (rxmatch-let (rxmatch #/(.*?) HTTP.*/ (cdr c)) (all filename)
          (message "~s\n" c)
          (let* ((filename
                  (if (string=? filename "/") "/index.html" filename))
                 (expanded-filename (full-path filename)))
            (cond
             ((file-is-regular? expanded-filename)
              (if (server-script? filename)
                  (handle-server-script filename output)
                  (handle-file filename output))
              (*statistics* 'hit))
             ((file-is-directory? expanded-filename)
              (handle-directory filename output)
              (*statistics* 'hit))
             (else
              (handle-error request output)
              (*statistics* 'miss)))))))
     (else
      (message "*** don't know what to do with this request\n~s\n" request)))))

(define (parse-request input)
  (do ((line (read-line input) (read-line input))
       (result '()))
      ;; BUG line can be an #<eof> object, too. string-length fails
      ;; in that case
      ((or (eof-object? line)
           (eq? (string-length line) 0)) result)
    (rxmatch-let (rxmatch #/(\w+):? (.*)/ line) (all tag value)
      (set! result (cons (cons (string->symbol tag) value) result)))))

;; (define (parse-request input)
;;   (let ((text (port->string-list input)))
;;     (format #t "REQ: ~s\n" text)
;;     '((GET . "/ HTTP/1.1"))))

(define (header)
  "HTTP/1.0 200 OK\nContent-type: text/html\n\n")

;; (define (html-message text)
;;   (string-append (header) "<html><body>" text "</body></html>"))

(define (http-server)
  (let ((selector (make <selector>))
        ;;(server   (make-server-socket 'inet port :reuse-addr? #t))
        ;; FIXME make-server-sockets could return more than one result
        (server (car (make-server-sockets
                      httpd-host httpd-port :reuse-addr? #t))))

    (define (accept-handler sock flag)
      (let* ((client (socket-accept server))
             (output (socket-output-port client)))
        (message "accept-handler ~s\n" client)
        (selector-add! selector
                       (socket-input-port client :buffered? #f)
                       (lambda (input flag)
                         (message "dispatch caller ~s\n"
                                  (list input flag output))
                         (dispatch client input output)
                         (flush output)
                         ;; TODO keep-alive
                         ;; (set SO_KEEPALIVE on socket?)
                         ;; keep socket around in a alist associated by
                         ;; client IP. Reuse the socket for subsequent
                         ;; requests
                         (selector-delete! selector input #f #f)
                         (socket-close client))
                       '(r))))

    (define (terminate)
      (socket-close server)
      (*statistics* 'print)
      (message "gauche/httpd terminated\n--------\n"))

    (selector-add! selector (socket-fd server) accept-handler '(r))

    (message "gauche/httpd ~a started @ ~d\n" httpd-version server)

    (call/cc
     (lambda (break)
       (set-signal-handler! SIGINT (lambda (s) (break)))
       (set-signal-handler! SIGTERM (lambda (s) (break)))
       (set-signal-handler! SIGHUP (lambda (s) (break)))
       (set-signal-handler! SIGPIPE #f) ; ignore
       (do () (#f)
         (with-error-handler
             (lambda (err)
               (message "*** oops: ~a\n" (slot-ref err 'message))
               (break))
           (lambda ()
             (message "selector-select\n")
             (selector-select selector))))))
    (terminate)))

(define *mime-mapper* (make-mime-mapper))
(define *statistics* (make-statistics-counter))

;; (define (main args)
;;     (http-server))

;;(define *message-port*
;;  (open-output-file "httpd.log" :if-exists :append :buffering :line))
(http-server)
;;(close-output-port *message-port*)

;; (read-eval-print-loop)