;;;===========================================================================
;;;
;;; mod-lisp.lisp
;;;
;;; Eduardo Muņoz
;;; Time-stamp: "Sunday, 26 December 2004 - 18:38:53"
;;;
;;;===========================================================================
;;;
;;; original mod-lisp.lisp author marc.battyani@fractalconcept.com
;;; ported to cmucl by dig@mail.com
;;; heavily modified by Eduardo Muņoz <emufer@terra.es>
;;;
;;;===========================================================================

(in-package :weblisp)

(defconstant +apache-port+ 3000)
(defvar *apache-stream* nil) ;the socket to apache
(defvar *close-apache-stream* nil) ;set to t if you want to close the socket to apache
(defvar *apache-nb-use-socket* 0) ;the number of requests sent in this socket
(defvar *handled-requests* 0)

(defun start-apache-listener ()
  (mp:make-process #'make-apache-listener :name "mod-lisp"))

(defun make-apache-listener ()
  (let ((socket (ext:create-inet-listener +apache-port+)))
    (unwind-protect
         (loop (mp:process-wait-until-fd-usable socket :input)
               (multiple-value-bind (new-fd remote-host)
                   (ext:accept-tcp-connection socket)
                 (declare (ignore remote-host))
                 (let ((stream (sys:make-fd-stream new-fd :input t :output t)))
                   (mp:make-process #'(lambda () (apache-listen stream))
                                    :name "http-serv"))))
      (unix:unix-close socket))))

(defun apache-listen (*apache-stream*)
  (let ((*close-apache-stream* t))
    (unwind-protect
         (loop for *apache-nb-use-socket* from 0
               for command = (get-apache-command)
               while command do
               (process-apache-command command)
               (force-output *apache-stream*)
               until *close-apache-stream*)
      (close *apache-stream*))))

(defun get-apache-command ()
  (ignore-errors
    (let* ((header (loop for key = (read-line *apache-stream* nil nil)
                         while (and key (string-not-equal key "end"))
                         for value = (read-line *apache-stream* nil nil)
                         collect (cons key value)))
           (content-length (cdr (assoc "content-length" header :test #'equal)))
           (content (when content-length
                      (make-string (parse-integer content-length
                                                  :junk-allowed t)))))
      (when content
        (read-sequence content *apache-stream*)
        (push (cons "posted-content" content) header))
      header)))

(defun process-apache-command (command)
  (let* ((url (cdr (assoc "url" command :test #'string=)))
         (pos (position #\? url)))
    (when pos
      (push (cons "url-query" (subseq url (1+ pos))) command)
      (setq url (subseq url 0 pos)))
    (multiple-value-bind (function found)
        (gethash url *apache-address-table*)
      (let ((handled-ok nil))
        (handler-case
            (progn
              (if found
                  (write-reply "200 OK" (funcall (page-function function) command))
                  (write-reply "404 Not Found" (get-http-error 404)))
              (incf *handled-requests*)
              (insert-log command)
              (setf handled-ok t))
          (error (e)
            (format t "~A~%" e)
            (force-output *standard-output*)
            (debug:backtrace)))
        (unless handled-ok
          (write-reply "503 Service Unavailable"
                       (get-http-error 503)))))))


(defun write-reply (status html)
  (write-header-line "Status" status)
  (write-header-line "Content-Type" "text/html")
  (write-header-line "Content-Length" (format nil "~d" (length html)))
  (write-header-line "Keep-Socket" "1")
  (write-string "end" *apache-stream*)
  (write-char #\NewLine *apache-stream*)
  (write-string html *apache-stream*)
  (setf *close-apache-stream* nil))

(defun write-header-line (key value)
  (write-string key *apache-stream*)
  (write-char #\NewLine *apache-stream*)
  (write-string value *apache-stream*)
  (write-char #\NewLine *apache-stream*))

(defun fetch-mod-lisp-url (server url &key (nb-fetch 1) (port +apache-port+) close-socket)
  (let ((socket (ext:connect-to-inet-socket server port))
        (reply))
    (unwind-protect
         (let ((stream (sys:make-fd-stream socket :input t :output t)))
           (dotimes (i nb-fetch)
             (write-string "url" stream)
             (write-char #\NewLine stream)
             (write-string url stream)
             (write-char #\NewLine stream)
             (write-string "end" stream)
             (write-char #\NewLine stream)
             (force-output stream)
             (setf reply (read-reply stream))
             (when close-socket
               (close stream)
               (setf stream nil))))
      (unix:unix-close socket))
    reply))

(defun read-reply (socket)
  (let* ((header (loop for key = (read-line socket nil nil)
                       while (and key (string-not-equal key "end"))
                       for value = (read-line socket nil nil)
                       collect (cons key value)))
         (content-length (cdr (assoc "Content-Length" header :test #'string=)))
         (content (when content-length
                    (make-string (parse-integer content-length :junk-allowed t)))))
    (when content
      (read-sequence content socket)
      (push (cons "reply-content" content) header))
    header))