;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
;;; $Header: src/hunchentoot.lisp $

;;; Copyright (c) 2008, Andrea Chiumenti.  All rights reserved.

;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:

;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.

;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.

;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(in-package :claw-hunchentoot-connector)

(setf hunchentoot:*hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf)
      hunchentoot:*default-content-type* "text/html; charset=utf-8"
      hunchentoot:*handle-http-errors-p* nil)

(defgeneric hunchentoot-to-claw-cookie (hunchentoot-cookie)
  (:documentation "Returns a claw cookie from a hunchentoot cookie"))

(defgeneric (setf hunchentoot-connector-mod-lisp-p) (mod-lisp-p hunchentoot-connector)
  (:documentation "When not null binds the claw server to apache using mod_lisp2. When server is started an error will be signaled."))

(defgeneric (setf hunchentoot-connector-use-apache-log-p) (apache-log-p hunchentoot-connector)
  (:documentation "When boud to apache with mod_lisp2 if not nil, uses apache logging.  When server is started an error will be signaled."))

(defgeneric (setf hunchentoot-connector-input-chunking-p) (input-chunking-p hunchentoot-connector)
  (:documentation "Sets input-chunking-p, when true the server will accept request
bodies without a Content-Length header if the client uses chunked transfer encoding.
If you want to use this feature behind mod_lisp, you should make sure that your combination of
Apache and mod_lisp can cope with that. When server is started an error will be signaled."))

(defgeneric (setf hunchentoot-connector-read-timeout) (read-timeout hunchentoot-connector)
  (:documentation "Sets the read timeout in seconds. When server is started an error will be signaled."))

(defgeneric (setf hunchentoot-connector-write-timeout) (write-timeout hunchentoot-connector)
  (:documentation "Sets the write timeout in seconds. When server is started an error will be signaled."))

#+(and :unix (not :win32)) (defgeneric (setf hunchentoot-connector-setuid) (setuid hunchentoot-connector)
			     (:documentation "Sets the uid under which the server runs (Only for *NIX). When server is started an error will be signaled."))

#+(and :unix (not :win32)) (defgeneric (setf hunchentoot-connector-setgid) (setgid hunchentoot-connector)
			     (:documentation "Sets the gid under which the server runs (Only for *NIX). When server is started an error will be signaled."))

#-:hunchentoot-no-ssl (defgeneric (setf hunchentoot-connector-ssl-certificate-file) (certificate-file hunchentoot-connector)
			(:documentation "The ssl certificate file for https connections. When server is started an error will be signaled."))

#-:hunchentoot-no-ssl (defgeneric (setf hunchentoot-connector-ssl-privatekey-file) (ssl-privatekey-file hunchentoot-connector)
			(:documentation "The ssl private key file for https connections. When server is started an error will be signaled."))

#-:hunchentoot-no-ssl (defgeneric (setf hunchentoot-connector-ssl-privatekey-password) (ssl-privatekey-password hunchentoot-connector)
			(:documentation "The password for the ssl private key file. When server is started an error will be signaled."))

(setf hunchentoot:*http-error-handler* nil)

(defclass hunchentoot-connector (connector)
  ((mod-lisp-p :initarg :mod-lisp-p
	       :reader hunchentoot-connector-mod-lisp-p
	       :documentation "Returns not nil when the server is bound to apache through mod_lisp")
   (use-apache-log-p :initarg :use-apache-log-p
		     :reader hunchentoot-connector-use-apache-log-p
		     :documentation "Returns not nil when the server uses apache logging")
   (input-chunking-p :initarg :input-chunking-p
		     :reader hunchentoot-connector-input-chunking-p
		     :documentation "When true the server will accept request
bodies without a Content-Length header if the client uses chunked transfer encoding.
If you want to use this feature behind mod_lisp, you should make sure that your combination of
Apache and mod_lisp can cope with that.")
   (read-timeout :initarg :read-timeout
		 :reader hunchentoot-connector-read-timeout
		 :documentation "Returns the server read timeout in seconds.")
   (write-timeout :initarg :write-timeout
                  :reader hunchentoot-connector-write-timeout
                  :documentation "Returns the server write timeout in seconds.")
   #+(and :unix (not :win32)) (setuid :initarg :setuid
				      :reader hunchentoot-connector-setuid
				      :documentation "Returns the uid under which the server runs.")
   #+(and :unix (not :win32)) (setgid :initarg :setgid
				      :reader hunchentoot-connector-setgid
				      :documentation "Returns the gid under which the server runs.")
   #-:hunchentoot-no-ssl (ssl-certificate-file :initarg :ssl-certificate-file
					       :reader hunchentoot-connector-ssl-certificate-file
					       :documentation "The ssl certificate file for https connections.")
   #-:hunchentoot-no-ssl (ssl-privatekey-file :initarg :ssl-privatekey-file
                                              :reader hunchentoot-connector-ssl-privatekey-file
                                              :documentation "The ssl private key file for https connections")
   #-:hunchentoot-no-ssl (ssl-privatekey-password :initarg :ssl-privatekey-password
                                                  :reader hunchentoot-connector-ssl-privatekey-password
                                                  :documentation "The password for the ssl private key file for https connections")
   (server :initform nil
	   :accessor hunchentoot-connector-server
	   :documentation "The hunchentoot server dispatching http requests.")
   (sslserver :initform nil
              :accessor hunchentoot-connector-sslserver
              :documentation "The hunchentoot server dispatching https requests."))
  (:default-initargs :mod-lisp-p nil
                     :use-apache-log-p nil
                     :input-chunking-p nil 
                     :read-timeout hunchentoot:*default-read-timeout*
                     :write-timeout hunchentoot:*default-write-timeout*
                     #+(and :unix (not :win32)) :setuid nil
                     #+(and :unix (not :win32)) :setgid nil
                     #-:hunchentoot-no-ssl :ssl-certificate-file nil
                     #-:hunchentoot-no-ssl :ssl-privatekey-file nil
                     #-:hunchentoot-no-ssl :ssl-privatekey-password nil)
  (:documentation "This is a connector between hunchentoot and the CLAW server CLAWSERVER object"))

(defmethod claw-service-start :before ((connector hunchentoot-connector))
  (let* ((server *claw-server*)
         (port (connector-port connector))
         (sslport (connector-sslport connector))
         (address (connector-address connector))
         (dispatch-table (list #'(lambda (request)
                                   (declare (ignore request))
                                   (claw-server-dispatch-method server))))
         (mod-lisp-p (hunchentoot-connector-mod-lisp-p connector))
         (use-apache-log-p (hunchentoot-connector-use-apache-log-p connector))
         (input-chunking-p (hunchentoot-connector-input-chunking-p connector))
         (read-timeout (hunchentoot-connector-read-timeout connector))
         (write-timeout (hunchentoot-connector-write-timeout connector))
         (uid (hunchentoot-connector-setuid connector))
         (gid (hunchentoot-connector-setgid connector))
         (ssl-certificate-file (hunchentoot-connector-ssl-certificate-file connector))
         (ssl-privatekey-file (hunchentoot-connector-ssl-privatekey-file connector))
         (ssl-privatekey-password (hunchentoot-connector-ssl-privatekey-password connector)))
    (progn
      (when port
        (setf (hunchentoot-connector-server connector)
              (hunchentoot:start-server :port port
                                        :address address
                                        :dispatch-table dispatch-table
                                        :mod-lisp-p mod-lisp-p
                                        :use-apache-log-p use-apache-log-p
                                        :input-chunking-p input-chunking-p
                                        :read-timeout read-timeout
                                        :write-timeout write-timeout
                                        #+(and :unix (not :win32)) :setuid uid
                                        #+(and :unix (not :win32)) :setgid gid)))
      (when sslport
        (setf (hunchentoot-connector-sslserver connector)
              (hunchentoot:start-server :port sslport
                                        :address address
                                        :dispatch-table dispatch-table
                                        :mod-lisp-p mod-lisp-p
                                        :use-apache-log-p use-apache-log-p
                                        :input-chunking-p input-chunking-p
                                        :read-timeout read-timeout
                                        :write-timeout write-timeout
                                        #+(and :unix (not :win32)) :setuid uid
                                        #+(and :unix (not :win32)) :setgid gid
                                        #-:hunchentoot-no-ssl :ssl-certificate-file ssl-certificate-file
                                        #-:hunchentoot-no-ssl :ssl-privatekey-file ssl-privatekey-file
                                        #-:hunchentoot-no-ssl :ssl-privatekey-password ssl-privatekey-password))))))

(defmethod claw-service-stop :before ((connector hunchentoot-connector))
  (let ((server (hunchentoot-connector-server connector))
        (sslserver (hunchentoot-connector-sslserver connector)))
    (when server
      (hunchentoot:stop-server server))
    (when sslserver
      (hunchentoot:stop-server sslserver))))

(defmethod connector-host ((connector hunchentoot-connector))
  (hunchentoot:host))

(defmethod connector-request-method ((connector hunchentoot-connector))
  (hunchentoot:request-method))

(defmethod connector-request-uri ((connector hunchentoot-connector))
  (hunchentoot:request-uri))

(defmethod connector-script-name ((connector hunchentoot-connector))
  (hunchentoot:script-name))

(defmethod connector-query-string ((connector hunchentoot-connector))
  (hunchentoot:query-string))

(defmethod connector-get-parameter ((connector hunchentoot-connector) name)
  (hunchentoot:get-parameter name))

(defmethod connector-get-parameters ((connector hunchentoot-connector))
  (hunchentoot:get-parameters))

(defmethod connector-post-parameter ((connector hunchentoot-connector) name)
  (hunchentoot:post-parameter name))

(defmethod connector-post-parameters ((connector hunchentoot-connector))
  (hunchentoot:post-parameters))

(defmethod connector-parameter ((connector hunchentoot-connector) name)
  (hunchentoot:parameter name))

(defmethod connector-header-in ((connector hunchentoot-connector) name)
  (hunchentoot:header-in (if (stringp name) name (symbol-name name))))

(defmethod connector-headers-in ((connector hunchentoot-connector))
  (hunchentoot:headers-in))

(defmethod connector-authorization ((connector hunchentoot-connector))
  (hunchentoot:authorization))

(defmethod connector-remote-addr ((connector hunchentoot-connector))
  (hunchentoot:remote-addr))

(defmethod connector-remote-port ((connector hunchentoot-connector))
  (hunchentoot:remote-port))

(defmethod connector-real-remote-addr ((connector hunchentoot-connector))
  (hunchentoot:real-remote-addr))

(defmethod connector-server-addr ((connector hunchentoot-connector))
  (hunchentoot:server-addr))

(defmethod connector-server-port ((connector hunchentoot-connector))
  (hunchentoot:server-port))

(defmethod connector-server-protocol ((connector hunchentoot-connector))
  (hunchentoot:server-protocol))

(defmethod connector-user-agent ((connector hunchentoot-connector))
  (hunchentoot:user-agent))


(defmethod connector-referer ((connector hunchentoot-connector))
  (hunchentoot:referer))

(defmethod connector-cookie-in (connector name)
  (hunchentoot:cookie-in name))

(defmethod connector-cookies-in ((connector hunchentoot-connector))
  (hunchentoot:cookies-in))

(defmethod connector-aux-request-value ((connector hunchentoot-connector) symbol)
  (hunchentoot:aux-request-value symbol))

(defmethod (setf connector-aux-request-value) (value (connector hunchentoot-connector) symbol)
  (setf (hunchentoot:aux-request-value symbol) value))

(defmethod connector-delete-aux-request-value ((connector hunchentoot-connector) symbol)
  (hunchentoot:delete-aux-request-value symbol))


;;---------------------------

(defmethod connector-header-out ((connector hunchentoot-connector) name)
  (hunchentoot:header-out name))

(defmethod (setf connector-header-out) (value (connector hunchentoot-connector) name)
  (setf (hunchentoot:header-out name) value))

(defmethod connector-headers-out ((connector hunchentoot-connector))
  (hunchentoot:headers-out))

(defmethod connector-cookie-out ((connector hunchentoot-connector) name)
  (let ((cookie (hunchentoot:cookie-out name)))
    (when cookie
      (hunchentoot-to-claw-cookie cookie))))

(defmethod (setf connector-cookie-out) (cookie-instance (connector hunchentoot-connector) name)
  (hunchentoot:set-cookie name 
                          :value (claw-cookie-value cookie-instance)
                          :expires (claw-cookie-expires cookie-instance)
                          :path (claw-cookie-path cookie-instance)
                          :domain (claw-cookie-domain cookie-instance)
                          :secure (claw-cookie-secure cookie-instance)
                          :http-only (claw-cookie-http-only cookie-instance)))

(defmethod connector-cookies-out ((connector hunchentoot-connector))
  (loop for cookie in (hunchentoot:cookies-out)
     collect (hunchentoot-to-claw-cookie cookie)))

(defmethod connector-return-code ((connector hunchentoot-connector))
  (hunchentoot:return-code))

(defmethod (setf connector-return-code) (value (connector hunchentoot-connector))
  (setf (hunchentoot:return-code) value))

(defmethod connector-content-type ((connector hunchentoot-connector))
  (hunchentoot:content-type))

(defmethod (setf connector-content-type) (value (connector hunchentoot-connector))
  (setf (hunchentoot:content-type) value))

(defmethod connector-reply-external-format-encoding ((connector hunchentoot-connector))
  (flexi-streams:external-format-name (hunchentoot:reply-external-format)))

(defmethod (setf connector-reply-external-format-encoding) (value (connector hunchentoot-connector))
  (let ((encoding (flexi-streams:external-format-name (hunchentoot:reply-external-format))))
    (unless (and (null value) (equal encoding value))
      (setf (hunchentoot:reply-external-format)
            (flex:make-external-format value :eol-style :lf)))))

(defmethod connector-writer ((connector hunchentoot-connector))
  (hunchentoot:send-headers))

(defmethod connector-redirect ((connector hunchentoot-connector) target &key host port protocol add-session-id code)
  (hunchentoot:redirect target
                        :host host
                        :port port
                        :protocol protocol
                        :add-session-id add-session-id
                        :code code))

(defmethod (setf hunchentoot-connector-mod-lisp-p) (mod-lisp-p (hunchentoot-connector hunchentoot-connector))
  (unless (null (hunchentoot-connector-server hunchentoot-connector))
    (error "Cannot change mod-lisp property when server is started"))
  (setf (slot-value hunchentoot-connector 'mod-lisp-p) mod-lisp-p))

(defmethod (setf hunchentoot-connector-use-apache-log-p) (use-apache-log-p (hunchentoot-connector hunchentoot-connector))
  (unless (null (hunchentoot-connector-server hunchentoot-connector))
    (error "Cannot change logging property when server is started"))
  (setf (slot-value hunchentoot-connector 'use-apache-log-p) use-apache-log-p))

(defmethod (setf hunchentoot-connector-input-chunking-p) (input-chunking-p (hunchentoot-connector hunchentoot-connector))
  (unless (null (hunchentoot-connector-server hunchentoot-connector))
    (error "Cannot change chunking property when server is started"))
  (setf (slot-value hunchentoot-connector 'input-chunking-p) input-chunking-p))

(defmethod (setf hunchentoot-connector-read-timeout) (read-timeout (hunchentoot-connector hunchentoot-connector))
  (unless (null (hunchentoot-connector-server hunchentoot-connector))
    (error "Cannot change read timeout property when server is started"))
  (setf (slot-value hunchentoot-connector 'read-timeout) read-timeout))

(defmethod (setf hunchentoot-connector-write-timeout) (write-timeout (hunchentoot-connector hunchentoot-connector))
  (unless (null (hunchentoot-connector-server hunchentoot-connector))
    (error "Cannot change write timeout property when server is started"))
  (setf (slot-value hunchentoot-connector 'write-timeout) write-timeout))

#+(and :unix (not :win32)) (defmethod (setf hunchentoot-connector-setuid) (setuid (hunchentoot-connector hunchentoot-connector))
			     (unless (null (hunchentoot-connector-server hunchentoot-connector))
			       (error "Cannot change uid property when server is started"))
			     (setf (slot-value hunchentoot-connector 'setuid) setuid))

#+(and :unix (not :win32)) (defmethod (setf hunchentoot-connector-setgid) (setgid (hunchentoot-connector hunchentoot-connector))
			     (unless (null (hunchentoot-connector-server hunchentoot-connector))
			       (error "Cannot change gid property when server is started"))
			     (setf (slot-value hunchentoot-connector 'setgid) setgid))

#-:hunchentoot-no-ssl (defmethod (setf hunchentoot-connector-ssl-certificate-file) (ssl-certificate-file (hunchentoot-connector hunchentoot-connector))
			(unless (null (hunchentoot-connector-server hunchentoot-connector))
			  (error "Cannot change ssl certificate file property when server is started"))
			(setf (slot-value hunchentoot-connector 'ssl-certificate-file) ssl-certificate-file))

#-:hunchentoot-no-ssl (defmethod (setf hunchentoot-connector-ssl-privatekey-file) (ssl-privatekey-file (hunchentoot-connector hunchentoot-connector))
			(unless (null (hunchentoot-connector-server hunchentoot-connector))
			  (error "Cannot change ssl privatekey file property when server is started"))
			(setf (slot-value hunchentoot-connector 'ssl-privatekey-file) ssl-privatekey-file))

#-:hunchentoot-no-ssl (defmethod (setf hunchentoot-connector-ssl-privatekey-password) (ssl-privatekey-password (hunchentoot-connector hunchentoot-connector))
			(unless (null (hunchentoot-connector-server hunchentoot-connector))
			  (error "Cannot change ssl privatekey password property when server is started"))
			(setf (slot-value hunchentoot-connector 'ssl-privatekey-password) ssl-privatekey-password))

(defmethod connector-content-length ((connector hunchentoot-connector))
  (hunchentoot:content-length))

(defmethod (setf connector-content-length) (value (connector hunchentoot-connector))
  (setf (hunchentoot:content-length) value))


(defmethod hunchentoot-to-claw-cookie ((cookie hunchentoot::cookie))
  (make-instance 'claw-cookie 
                 :name (hunchentoot:cookie-name cookie)
                 :value (hunchentoot:cookie-value cookie)
                 :expires (hunchentoot:cookie-expires cookie)
                 :path (hunchentoot:cookie-path cookie)
                 :domoain (hunchentoot:cookie-domain cookie)
                 :secure (hunchentoot:cookie-secure cookie)
                 :http-only (hunchentoot:cookie-http-only cookie)))

(defclass hunchentoot-logger (logger)
  ()
  (:documentation "Logger for hunchentoot"))

(defmethod logger-log ((logger hunchentoot-logger) level control-string &rest rest)
  (apply #'hunchentoot:log-message level control-string rest))