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

(defgeneric claw-server-register-lisplet (claw-server lisplet)
  (:documentation "This method registers a lisplet for request dispatching
- claw-server the claw-server instance
- LISPLET the LISPLET instance"))

(defgeneric claw-server-unregister-lisplet (claw-server lisplet)
  (:documentation "This method unregisters a lisplet from request dispatching
- claw-server the claw-server instance
- LISPLET the LISPLET instance"))

(defgeneric lisplet-register-function-location (lisplet function location &key welcome-page-p login-page-p)
  (:documentation "Registers a function into a lisplet for dispatching.
parameters:
- LISPLET the lisplet that will dispatch the function
- FUNCTION the function to register for dispatching
- LOCATION The url location where the function will be registered (relative to the lisplet base path)
keys:
- :WELCOME-PAGE-P When true, the function will be a welcome page, making the lisplet to redirect direct access to its base path to the expressed location
- :LOGIN-PAGE-P Marks the function as a login page"))

(defgeneric lisplet-register-resource-location (lisplet resource-path location &optional content-type)
  (:documentation "Registers a resource (file or directory) into a lisplet for dispatching.
parameters:
- LISPLET the lisplet that will dispatch the page
- RESOURCE-PATH pathname of a file or directory that is to be registered for dispatching
- LOCATION The url location where the resource will be registered (relative to the lisplet base path)
- CONTENT-TYPE Meaningful only when the resource-path points to a file, indicates the resource content type"))

(defgeneric lisplet-dispatch-method (lisplet)
  (:documentation "Performs authorizations checking then makes a call to LISPLET-DISPATCH-REQUEST
- LISPLET the lisplet object"))

(defgeneric lisplet-dispatch-request (lisplet uri)
  (:documentation "Dispatches the http request.
- LISPLET the lisplet object"))

(defgeneric lisplet-protect (lisplet location roles)
  (:documentation "protects all the resources that start with the given LOCATION, making them available only if the
user is logged and belongs at least to one of the given roles.
parameters:
- LISPLET the lisplet object.
- LOCATION the location that must be protected.
- ROLES a string list containing all the roles allowed to acces the given location."))

(defgeneric lisplet-check-authorization (lisplet)
  (:documentation "Performs authentication and authorization checking.
Sets the return code of each REPLY, to +HTTP-OK+, +HTTP-FORBIDDEN+ or +HTTP-AUTHORIZATION-REQUIRED+. If the
lisplet authentication type is :BASIC and the user isn't logged in, asks for a basic login."))

(defgeneric lisplet-authentication-type (lisplet)
  (:documentation "When there is no page or function registered into the lisplet as login page returns :BASIC, otherwise returns :FORM.
parameters:
- LISPLET the lisplet object."))

(defgeneric build-lisplet-location (lisplet)
  (:documentation "Constructs a full path prepending the lisplet base path to the given location"))

(defclass lisplet (claw-service)
  ((base-path :initarg :base-path
              :reader lisplet-base-path
              :documentation "common base path all resources registered into this lisplet")
   (server-address :initarg :server-address
                 :accessor lisplet-server-address
                 :documentation "Server address used on redirections")
   (welcome-page :initarg :welcome-page
                 :accessor lisplet-welcome-page
                 :documentation "url location for the welcome page")
   (login-page :initarg :login-page
               :accessor lisplet-login-page
               :documentation "url location for the welcome page")
   (realm :initarg :realm
          :reader lisplet-realm
          :documentation "realm for requests that pass through this lisplet and session opened into this lisplet. Must be a symbol")
   (pages :initform nil
          :accessor lisplet-pages
          :documentation "A collection of cons where the car is an url location and the cdr is a dispatcher")
   (error-handlers :initform (make-hash-table)
                   :accessor lisplet-error-handlers
                   :documentation "An hash table where keys are http error codes and values are functions with no parameters")
   (protected-resources :initform nil
                        :accessor lisplet-protected-resources
                        :documentation "A collection of cons where the car is the protected url location and the cdr is a string list of roles allowhed to access the relative location")
   (redirect-protected-resources-p :initarg :redirect-protected-resources-p
                                   :accessor lisplet-redirect-protected-resources-p
                                   :documentation "When not null every request will be redirected in https mode. When running in mod-lisp mode, *apache-http-port* and *apache-https-port* values are used"))
  (:default-initargs :server-address *claw-default-server-address*
   :welcome-page nil
   :login-page nil
   :realm 'claw
   :redirect-protected-resources-p nil)
  (:documentation "A lisplet is a container for resources provided trhough the claw-server.
It is similar, for purposes, to a JAVA servlet"))

(defmethod claw-server-register-lisplet ((claw-server claw-server) (lisplet lisplet))
  (let ((lisplets (claw-server-lisplets claw-server))
        (location (lisplet-base-path lisplet)))
    (when (or (string= "" location) (not (starts-with-subseq "/" location)))
      (setf location (concatenate 'string "/" location)))
    (setf (lisplet-server-address lisplet) (claw-server-address claw-server)
          (claw-server-lisplets claw-server) (sort-by-location (pushnew-location
                                                              (cons location
                                                                    lisplet)
                                                              lisplets)))))

(defmethod claw-server-unregister-lisplet ((claw-server claw-server) (lisplet lisplet))
  (let ((lisplets (claw-server-lisplets claw-server))
        (location (lisplet-base-path lisplet)))
    (unless (string= "/" (subseq location 0 1))
      (setf location (concatenate 'string "/" location)))
    (remove-by-location location lisplets)))


(defmethod build-lisplet-location ((lisplet lisplet))
  "Constructs a full path prepending the lisplet base path to the given location"
  (format nil "~a~a"  (claw-server-base-path *claw-server*) (lisplet-base-path lisplet)))

(defmethod lisplet-authentication-type ((lisplet lisplet))
  (if (lisplet-login-page lisplet)
      :form
      :basic))

(defmethod lisplet-register-function-location ((lisplet lisplet) function location &key welcome-page-p login-page-p)
  (unless (string= "/" (subseq location 0 1))
    (setf location (concatenate 'string "/" location)))
  (let ((pages (lisplet-pages lisplet)))
    (setf (lisplet-pages lisplet)
          (sort-by-location (pushnew-location (cons location function) pages)))
    (when welcome-page-p
      (setf (lisplet-welcome-page lisplet) location))
    (when login-page-p
      (setf (lisplet-login-page lisplet) location))))

(defmethod lisplet-register-resource-location ((lisplet lisplet) resource-path location &optional content-type)
  (unless (string= "/" (subseq location 0 1))
    (setf location (concatenate 'string "/" location)))
  (let ((pages (lisplet-pages lisplet)))
    (setf (lisplet-pages lisplet)
          (sort-by-location (pushnew-location
                             (cons location
                                   (if (directory-pathname-p resource-path)
                                       #'(lambda ()
                                           (let ((resource-full-path (merge-pathnames
                                                                      (uri-to-pathname (subseq (claw-script-name)
                                                                                               (+ (length (claw-server-base-path *claw-server*))
                                                                                                  (length (lisplet-base-path lisplet))
                                                                                                  (length location) )))
                                                                      resource-path)))
                                             (claw-handle-static-file resource-full-path content-type)))
                                       #'(lambda () (claw-handle-static-file resource-path content-type))))
                             pages)))))


(defmethod lisplet-dispatch-request ((lisplet lisplet) uri)
  (let ((dispatchers (lisplet-pages lisplet))
        (rel-script-name (subseq uri (length (build-lisplet-location lisplet)))))
    (setf (claw-return-code) +http-not-found+)
    (loop for dispatcher in dispatchers
       for url = (car dispatcher)
       for action = (cdr dispatcher)
       do (when (starts-with-subseq url rel-script-name) 
            (setf (claw-return-code) +http-ok+)
            (return (funcall action))))))

(defmethod lisplet-dispatch-method ((lisplet lisplet))
  (let* ((*claw-current-realm* (lisplet-realm lisplet))
         (*claw-current-lisplet* lisplet)
         (*claw-session* (default-session-manager-session-verify *session-manager*))
         (*root-path* (format nil "~a~a" *server-path* (lisplet-base-path lisplet)))
         (base-path (build-lisplet-location lisplet))
         (uri (claw-script-name))
         (welcome-page (lisplet-welcome-page lisplet)))
    (lisplet-check-authorization lisplet)
    (when (= (claw-return-code) +http-ok+)
      (if (and welcome-page (or (string= uri base-path) (string= uri (concatenate 'string base-path "/"))))
          (let* ((protocol (if (= (claw-server-port)
                                  (connector-port (claw-server-connector *claw-server*)))
                               :http
                               :https))
                 (port (if (equal protocol :http)
                           (if (claw-proxified-p)
                               (claw-server-proxy-http-port *claw-server*)
                               (claw-server-port))
                           (if (claw-proxified-p)
                               (claw-server-proxy-https-port *claw-server*)
                               (claw-server-port)))))
            (claw-redirect (format nil "~a~a" uri (if (ends-with-subseq "/" uri)
                                                      (subseq welcome-page 1)
                                                      welcome-page))
                           :protocol protocol
                           :port port)))
          (lisplet-dispatch-request lisplet uri))))

(defmethod lisplet-protect ((lisplet lisplet) location roles)
  (let ((protected-resources (lisplet-protected-resources lisplet)))
    (setf (lisplet-protected-resources lisplet)
          (sort-protected-resources (pushnew-location
                                     (cons location roles)
                                     protected-resources)))))

(defun redirect-to-https (&optional uri)
  "Redirects a request sent through http using https"
  (let* ((connector (claw-server-connector *claw-server*))
         (path (or uri (claw-request-uri)))
         (sslport (and (connector-sslport connector) (if (claw-proxified-p)
                                                         (claw-server-proxy-https-port *claw-server*)
                                                         (connector-sslport connector)))))
    (claw-redirect path :host (claw-host-name) :port (or sslport (connector-port connector))
                   :protocol (if sslport
                                 :https
                                 :http))))

(defmethod lisplet-check-authorization ((lisplet lisplet))
  (let* ((connector (claw-server-connector *claw-server*))
         (uri (claw-script-name))
         (base-path (build-lisplet-location lisplet))
         (protected-resources (lisplet-protected-resources lisplet))
         (princp (current-principal))
         (login-config (current-config))
         (login-page-url (format nil "~a~a" base-path (lisplet-login-page lisplet)))
         (sslport (connector-sslport connector))
         (auth-basicp (eq (lisplet-authentication-type lisplet) :basic)))
    (when (or (string= uri base-path) (string= uri (concatenate 'string base-path "/")))
      (setf uri (format nil "~a/~a" base-path uri)))
    (setf (claw-return-code) +http-ok+)
    (when login-config
      (when (and auth-basicp (null princp))
        (configuration-login login-config))
      (setf princp (current-principal))
      (loop for protected-resource in (append (list (cons (lisplet-login-page lisplet) nil)) protected-resources)
         for match = (format nil "~a/~a" base-path (car protected-resource))
         for allowed-roles = (cdr protected-resource)
         do
         (progn
           (when (or (starts-with-subseq match uri) (string= login-page-url uri))
             (cond
               ((and princp allowed-roles (not (user-in-role-p allowed-roles)) (not (string= login-page-url uri)))
                (setf (claw-return-code) +http-forbidden+)
                (throw 'handler-done nil))
               ((and (null princp) auth-basicp)
                (setf (claw-return-code) +http-authorization-required+
                      (claw-header-out "WWW-Authenticate") (format nil "Basic realm=\"~A\"" *claw-current-realm*))
                (throw 'handler-done nil))
               ((and (null princp)
                     (string-not-equal (claw-script-name) login-page-url))
                (redirect-to-https (format nil "~a~a" *root-path* (lisplet-login-page lisplet))))
               ((and sslport (not (= (claw-server-port) sslport)))
                (redirect-to-https (format nil "~a/~a" *root-path* (car protected-resource)))
                (throw 'handler-done nil)))))))))