;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
;;; $Header: src/server.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)

(defgeneric clawserver-dispatch-request (clawserver)
  (:documentation "Dispatches http requests through registered dispatchers"))

(defgeneric clawserver-dispatch-method (clawserver)
  (:documentation "Uses CLAWSERVER-DISPATCH-REQUEST to perform dispatching"))

(defgeneric clawserver-start (clawserver)
  (:documentation "Starts the server"))

(defgeneric clawserver-stop (clawserver)
  (:documentation "Stops the server"))

(defgeneric (setf clawserver-port) (port clawserver)
  (:documentation "Sets the claw server http port. When server is started an error will be signaled."))

(defgeneric (setf clawserver-sslport) (sslport clawserver)
  (:documentation "Sets the claw server https port. When server is started an error will be signaled."))

(defgeneric (setf clawserver-address) (address clawserver)
  (:documentation "Binds the claw server to a specific address.  When server is started an error will be signaled."))

(defgeneric (setf clawserver-name) (name clawserver)
  (:documentation "Sets the name of the server that dispatches http requests."))

(defgeneric (setf clawserver-sslname) (sslname clawserver)
  (:documentation "Sets the name of the server that dispatches https requests."))

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

(defgeneric (setf clawserver-use-apache-log-p) (apache-log-p clawserver)
  (: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 clawserver-input-chunking-p) (input-chunking-p clawserver)
  (: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 clawserver-read-timeout) (read-timeout clawserver)
  (:documentation "Sets the read timeout in seconds. When server is started an error will be signaled."))

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

#+(and :unix (not :win32)) (defgeneric (setf clawserver-setuid) (setuid clawserver)
			     (: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 clawserver-setgid) (setgid clawserver)
			     (: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 clawserver-ssl-certificate-file) (certificate-file clawserver)
			(:documentation "The ssl certificate file for https connections. When server is started an error will be signaled."))

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

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

(defgeneric clawserver-register-configuration(clawserver realm configuration)
  (:documentation "Registers a configuration object for the given realm into the server. The configuration
will perform the authentication logic."))

(defgeneric configuration-login (configuration &optional request)
  (:documentation "Authenticate a user creating a principal object that will be stored into the http session.
If no session is present one will be created, if the authentication succeds the principal instance is returned"))

(defclass error-page (page)
  ((title :initarg :title
	  :reader page-title
	  :documentation "The page title")
   (error-code :initarg :error-code
	       :reader page-error-code
	       :documentation "The error code to display"))
  (:documentation "This is the page class used to render
the http error messages."))

(defclass error-page-template (wcomponent)
  ((title :initarg :title
	  :reader title
	  :documentation "The page title")
   (error-code :initarg :error-code
	  :reader error-code
	  :documentation "The http error code. For details consult http://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html")
   (style :initarg :style
	  :reader style
	  :documentation "The CSS <style> element, used to beautify the error page."))
  (:default-initargs :style "
body {
  font-family: arial, elvetica;
  font-size: 7pt;
}
span.blue {
  background-color: #525D76;
  color: white;
  font-weight: bolder;
  margin-right: .25em;
}
p.h1, p.h2 {
  background-color: #525D76;
  color: white;
  font-weight: bolder;
  font-size: 2em;
  margin: 0;
  margin-bottom: .5em;
}
p.h2 {font-size: 1.5em;}" :empty t :allow-informal-parameters nil)
  (:metaclass metacomponent)
  (:documentation "The template for the error-page"))

(let ((class (find-class 'error-page-template)))
  (closer-mop:ensure-finalized class)
  (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function)
	(format nil "Description: ~a~%Parameters:~%~a~%~%~a"
		"Function that instantiates an ERROR-PAGE-TEMPLATE component and renders a html tenplate for CLAW generic error pages."
		(describe-html-attributes-from-class-slot-initargs class)
		(describe-component-behaviour class))))

(defmethod wcomponent-template ((error-page-template error-page-template))
  (let ((error-code (error-code error-page-template))
	(title (title error-page-template))
	(style (style error-page-template)))
    (html>
     (head>
      (title> title)
      (style> style))
     (body>
      (p>
       (p> :class "h1"
	   (format nil "HTTP Status ~a - ~a" error-code (request-uri *request*)))
       (hr> :noshade "noshade")
       (p>
	(span> :class "blue"
	       ($> "type"))
	"Status report")
       (p>
	(span> :class "blue"
	       "url")
	(request-uri *request*))
       (p>
	(span> :class "blue"
	       "description")
	(gethash error-code hunchentoot::*http-reason-phrase-map*)
	(hr> :noshade "noshade"))
       (p> :class "h2"
	   "claw server"))))))

(defmethod page-content ((error-page error-page))
  (error-page-template> :title (page-title error-page)
			:error-code (page-error-code error-page)
			(format nil "The requested resource (~a) is not available." (request-uri *request*))))

(defclass clawserver ()
  ((base-path :initarg :base-path
	      :accessor clawserver-base-path
	      :documentation "This slot is used to keep all server resources under a common URL")
   (port :initarg :port
	 :reader clawserver-port
	 :documentation "Returns the claw server http port")
   (sslport :initarg :sslport
	 :reader clawserver-sslport
	 :documentation "Returns the claw server https port")
   (address :initarg :address
	    :reader clawserver-address
	    :documentation "Returns the address where claw server is bound to.")
   (name :initarg :name
	 :reader clawserver-name
	 :documentation "Returns the name of the server that dispatches http requests.")
   (sslname :initarg :sslname
	 :reader clawserver-sslname
	 :documentation "Returns the name of the server that dispatches https requests.")
   (mod-lisp-p :initarg :mod-lisp-p
	       :reader clawserver-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 clawserver-use-apache-log-p
		     :documentation "Returns not nil when the server uses apache logging")
   (input-chunking-p :initarg :input-chunking-p
		     :reader clawserver-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 clawserver-read-timeout
		 :documentation "Returns the server read timeout in seconds.")
   (write-timeout :initarg :write-timeout
		 :reader clawserver-write-timeout
		 :documentation "Returns the server write timeout in seconds.")
   (login-config :initform (make-hash-table :test 'equal)
		 :accessor clawserver-login-config
		 :documentation "An hash table holding a pair of realm,
expressed as string, and a predicate. The predicate should take two arguments (login and password), and return a principal instance if the login call
succeeds.")
   #+(and :unix (not :win32)) (setuid :initarg :setuid
				      :reader clawserver-setuid
				      :documentation "Returns the uid under which the server runs.")
   #+(and :unix (not :win32)) (setgid :initarg :setgid
				      :reader clawserver-setgid
				      :documentation "Returns the gid under which the server runs.")
   #-:hunchentoot-no-ssl (ssl-certificate-file :initarg :ssl-certificate-file
					       :reader clawserver-ssl-certificate-file
					       :documentation "The ssl certificate file for https connections.")
   #-:hunchentoot-no-ssl (ssl-privatekey-file :initarg :ssl-privatekey-file
					       :reader clawserver-ssl-privatekey-file
					       :documentation "The ssl private key file for https connections")
   #-:hunchentoot-no-ssl (ssl-privatekey-password :initarg :ssl-privatekey-password
					       :reader clawserver-ssl-privatekey-password
					       :documentation "The password for the ssl private key file for https connections")
   (server :initform nil
	   :accessor clawserver-server
	   :documentation "The hunchentoot server dispatching http requests.")
   (sslserver :initform nil
	   :accessor clawserver-sslserver
	   :documentation "The hunchentoot server dispatching https requests.")
   (dispatchers :initform nil
	     :accessor clawserver-dispatchers
	     :documentation "A collection of cons where the car is an url location where a lisplet is registered and the cdr is a dispatcher for that lisplet"))
  (:default-initargs :base-path ""
    :use-apache-log-p nil
    :address nil
    :name (gensym)
    :sslname (gensym)
    :port 80
    :sslport 443
    :mod-lisp-p nil
    :input-chunking-p t
    :read-timeout *default-read-timeout*
    :write-timeout *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-password nil)
  (:documentation "CLAWSERVER is built around huncentoot and has the
instructions for lisplet dispatching, so use this class to start and stop
3hunchentoot server."))

(defclass configuration ()
  ()
  (:documentation "A configuration class for CLAW server realm login configurations"))

(defmethod configuration-login ((configuration configuration) &optional (request *request*))
  (declare (ignore request)))

(defclass principal ()
  ((name :initarg :name
	 :reader principal-name
	 :documentation "The principal username who is logged into the application")
   (roles :initarg :roles
	  :accessor principal-roles
	  :documentation "The roles where that owns the user logged into the application"))
  (:default-initargs :roles nil)
  (:documentation "An instance of PRINCIPAL is stored into session after a user successfully login into the application."))

(defmethod initialize-instance :after ((clawserver clawserver) &rest keys)
  (let ((use-apache-log-p (getf keys :use-apache-log-p :undefined))
	#-:hunchentoot-no-ssl (ssl-privatekey-file (getf keys :ssl-privatekey-file :undefined)))
    (when (eq use-apache-log-p :undefined)
      (setf (clawserver-use-apache-log-p clawserver) (getf keys :mod-lisp-p)))
    #-:hunchentoot-no-ssl (when (eq ssl-privatekey-file :undefined)
			    (setf (clawserver-ssl-privatekey-file clawserver) (getf keys :ssl-certificate-file)))))

;;;-------------------------- WRITERS ----------------------------------------

(defmethod (setf clawserver-port) (port (clawserver clawserver))
  (unless (null (clawserver-server clawserver))
    (error "Cannot change port when server is started"))
  (setf (slot-value clawserver 'port) port))

(defmethod (setf clawserver-sslport) (sslport (clawserver clawserver))
  (unless (null (clawserver-server clawserver))
    (error "Cannot change SSL port when server is started"))
  (setf (slot-value clawserver 'sslport) sslport))

(defmethod (setf clawserver-address) (address (clawserver clawserver))
  (unless (null (clawserver-server clawserver))
    (error "Cannot change binding address when server is started"))
  (setf (slot-value clawserver 'address) address))

(defmethod (setf clawserver-name) (name (clawserver clawserver))
  (unless (null (clawserver-server clawserver))
    (setf (server-name (clawserver-server clawserver)) name))
  (setf (slot-value clawserver 'name) name))

(defmethod (setf clawserver-sslname) (sslname (clawserver clawserver))
  (unless (null (clawserver-sslserver clawserver))
    (setf (server-name (clawserver-sslserver clawserver)) sslname))
  (setf (slot-value clawserver 'sslname) sslname))

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

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

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

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

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

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

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

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

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

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

;;;-------------------------- METHODS ----------------------------------------

(defmethod clawserver-register-configuration ((clawserver clawserver) realm (configuration configuration))
  (setf (gethash realm (clawserver-login-config clawserver)) configuration))


(defmethod clawserver-dispatch-request ((clawserver clawserver))
  (let ((base-path (clawserver-base-path clawserver))
	(dispatchers (clawserver-dispatchers clawserver))
	(script-name (script-name))
	(rel-script-name)
        (rel-script-name-libs))
    (setf (current-server) clawserver)
    (when (starts-with-subseq script-name base-path)
      (setf rel-script-name (subseq script-name (length base-path))
            rel-script-name-libs (subseq script-name (1+ (length base-path))))
      (or
       (loop for dispatcher in *claw-libraries-resources*
	  for url = (car dispatcher)
	  for action = (cdr dispatcher)
	  do (when (starts-with-subseq rel-script-name-libs url) (funcall action)))
       (loop for dispatcher in dispatchers
	  for url = (car dispatcher)
	  for action = (cdr dispatcher)
	  do (when (starts-with-subseq rel-script-name url) (return (funcall action))))))))

(defmethod clawserver-dispatch-method ((clawserver clawserver))
  (let ((result (clawserver-dispatch-request clawserver)))
    (if (null result)
	#'(lambda () (when (= (return-code) +http-ok+)
		       (setf (return-code *reply*) +http-not-found+)))
	#'(lambda () result))))

(defmethod clawserver-start ((clawserver clawserver))
  (let ((port (clawserver-port clawserver))
	(sslport (clawserver-sslport clawserver))
	(address (clawserver-address clawserver))
	(dispatch-table (list #'(lambda (request)
				  (declare (ignorable request))
				  (clawserver-dispatch-method clawserver))))
	(name (clawserver-name clawserver))
	(sslname (clawserver-sslname clawserver))
	(mod-lisp-p (clawserver-mod-lisp-p clawserver))
	(use-apache-log-p (clawserver-use-apache-log-p clawserver))
	(input-chunking-p (clawserver-input-chunking-p clawserver))
	(read-timeout (clawserver-read-timeout clawserver))
	(write-timeout (clawserver-write-timeout clawserver))
	(uid (clawserver-setuid clawserver))
	(gid (clawserver-setgid clawserver))
	(ssl-certificate-file (clawserver-ssl-certificate-file clawserver))
	(ssl-privatekey-file (clawserver-ssl-privatekey-file clawserver))
	(ssl-privatekey-password (clawserver-ssl-privatekey-password clawserver)))
    (progn
      (setf (clawserver-server clawserver)
	    (start-server :port port
			  :address address
			  :dispatch-table dispatch-table
			  :name name
			  :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 (when ssl-certificate-file
			      (setf (clawserver-sslserver clawserver)
				    (start-server :port sslport
						  :address address
						  :dispatch-table dispatch-table
						  :name sslname
						  :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
						:ssl-certificate-file ssl-certificate-file
						:ssl-privatekey-file ssl-privatekey-file
						:ssl-privatekey-password ssl-privatekey-password))))))

(defmethod clawserver-stop ((clawserver clawserver))
  (progn
    (setf (clawserver-server clawserver) (stop-server (clawserver-server clawserver)))
    (when (clawserver-sslserver clawserver)
      (setf (clawserver-sslserver clawserver) (stop-server (clawserver-sslserver clawserver))))))
;;;----------------------------------------------------------------------------
(defun login (&optional (request *request*))
  "Perform user authentication for the reaml where the request has been created"
  (let* ((server (current-server request))
	 (realm  (current-realm request))
	 (login-config (gethash realm (clawserver-login-config server))))
    (configuration-login login-config request)))