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

(setf *hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf))

(defvar *apache-http-port* 80
  "Default apache http port when claw is running in mod_lisp mode")
(defvar *apache-https-port* 443
  "Default apache https port when claw is running in mod_lisp mode")

(defvar *claw-libraries-resources* ()
  "Global variable to hold exposed web resources")

(defun strings-to-jsarray (strings)
  "Transforms a list of strings into a javascript array."
  (let ((st-size (length strings))
        (items ""))
    (cond ((= st-size 0) "[]")
          ((= st-size 1) (format nil "[~a]" (prin1-to-string (first strings))))
          (t (format nil (format nil "[~a~a]"
                                 (prin1-to-string (first strings))
                                 (progn
                                   (dolist (str (rest strings))
                                     (setf items (format nil "~a,~a"
                                                         items (prin1-to-string str))))
                                   items)))))))

(defun sort-by-location (location-list)
  "Sorts a list of location items by their first element (the location itself)."
  (sort location-list #'(lambda (item1 item2)
                          (string-not-lessp (first item1) (first item2)))))

(defun sort-protected-resources (protected-resources)
  "Sorts a list of protected resources. A protected resource is a cons where the car is the url
of the resource and the cdr is a list of roles allowhed to access that resource."
  (sort protected-resources #'(lambda (item1 item2)
                                (string-lessp (car item1) (car item2)))))

(defun remove-by-location (location location-list)
  "Removes an item from LOCATION-LIST checking its first element
against the LOCATION parameter"
  (delete-if #'(lambda (item) (string= (first item) location)) location-list))

(defun pushnew-location (location-items location-list)
  "Isert a new location info items into a list, or replace the one that has the same location
registered (its first element)."
  (let ((result (remove-by-location (first location-items) location-list)))
    (setf result (push location-items result))))

(defun claw-start-session ()
  "Starts a session bound to the current lisplet base path"
  (start-session (format nil "~a/" (build-lisplet-location (current-lisplet)))))


(defun current-page (&optional (request *request*))
  "Returns the page that is rendering"
  (aux-request-value 'page request))

(defun (setf current-page) (page &optional (request *request*))
  "Setf the page that is to be rendered"
  (setf (aux-request-value 'page request) page))

(defun current-realm (&optional (request *request*))
  "Returns the realm under which the request has been sent"
  (aux-request-value 'realm request))

(defun (setf current-realm) (realm &optional (request *request*))
  "Setf the realm under which the request has been sent"
  (setf (aux-request-value 'realm request) realm))

(defun current-lisplet (&optional (request *request*))
  "Returns the lisplet instance from which the request comes from"
  (aux-request-value 'lisplet request))

(defun (setf current-lisplet) (lisplet &optional (request *request*))
  "Sets the lisplet instance from which the request comes from"
  (setf (aux-request-value 'lisplet request) lisplet))

(defun current-server (&optional (request *request*))
  "Returns the clawserver instance from which the request comes from"
  (aux-request-value 'clawserver request))

(defun (setf current-server) (server &optional (request *request*))
  "Sets the clawserver instance from which the request comes from"
  (setf (aux-request-value 'clawserver request) server))

(defun current-principal (&optional (session *session*))
  "Returns the principal(user) that logged into the application"
  (when session
    (session-value 'principal session)))

(defun (setf current-principal) (principal &optional (session *session*))
  "Setf the principal(user) that logged into the application"
  (unless session
    (setf session (claw-start-session)))
  (setf (session-value 'principal session) principal))

(defun user-in-role-p (roles &optional (session *session*))
  "Detects if current principal belongs to any of the expressed roles"
  (let ((principal (current-principal session)))
    (when principal
      (loop for el in (principal-roles principal) thereis (member el roles)))))

(defun current-config (&optional (request *request*))
  "Returns the current configuration object for the realm of the request"
  (gethash (current-realm request) (clawserver-login-config (current-server request))))

(defun login (&optional (request *request*))
  "Perfoms a login action using the configuration object given for the request realm (see CURRENT-REALM)"
  (configuration-login (current-config request)))

(defun flatten (tree &optional result-list)
  "Traverses the tree in order, collecting even non-null leaves into a list."
  (let ((result result-list))
    (loop for element in tree
       do (cond
            ((consp element) (setf result (append (nreverse (flatten element result-list)) result)))
            (t (push element result))))
    (nreverse result)))

(defun msie-p (&optional (request *request*))
  "Returns nil when the calling browser is not the evil of MSIE"
  (let* ((header-props (headers-in request))
         (user-agent (find :USER-AGENT header-props :test #'(lambda (member value) (eq member (car value))))))
    (when user-agent
      (all-matches "MSIE" (string-upcase (cdr user-agent))))))

(defmacro with-message (key &optional (default "") locale)
  "Returns a lambda function that can localize a message by its key.
The first message dispatching is made by the lisplet, then, if the message is not already vlorized the
computation is left to the current rendering page, then to the current rendering web component.
If the message is null after these passages the default value is used."
  (let ((current-lisplet (gensym))
        (current-page (gensym))
        (current-component (gensym))
        (result (gensym))
        (key-val key)
        (locale-val (gensym))
        (default-val default))
    `#'(lambda ()
         (let ((,current-lisplet (current-lisplet))
               (,current-page (current-page))
               (,current-component (current-component))
               (,locale-val ,locale)
               (,result))
           (unless ,locale-val
             (setf ,locale-val (user-locale)))
           (when ,current-lisplet
             (setf ,result (message-dispatch ,current-lisplet ,key-val ,locale-val)))
           (when (and (null ,result) ,current-page)
             (setf ,result (message-dispatch ,current-page ,key-val ,locale-val)))
           (when (and (null ,result) ,current-component)
             (setf ,result (message-dispatch ,current-component ,key-val ,locale-val)))
           (when (null ,result)
             (setf ,locale-val "")
             (when ,current-lisplet
               (setf ,result (message-dispatch ,current-lisplet ,key-val ,locale-val)))
             (when (and (null ,result) ,current-page)
               (setf ,result (message-dispatch ,current-page ,key-val ,locale-val)))
             (when (and (null ,result) ,current-component)
               (setf ,result (message-dispatch ,current-component ,key-val ,locale-val))))
           (if ,result
               ,result
               ,default-val)))))

(defun do-message (key &optional (default "") locale)
  "This function calls the lambda function returned by the WITH-MESSAGE macro."
  (funcall (with-message key default locale)))

(defun user-locale (&optional (request *request*) (session *session*))
  "This function returns the user locale. If no locale was directly set, the browser default locale is used."
  (let ((locale (when session
                  (session-value 'locale session))))
    (unless locale
      (setf locale (first (loop for str in (all-matches-as-strings
                                            "[A-Z|a-z|_]+"
                                            (regex-replace-all "-" (regex-replace-all ";.*" (header-in "ACCEPT-LANGUAGE" request) "") "_"))
                             collect (if (> (length str) 2)
                                         (string-upcase str :start 2)
                                         str)))))
    locale))

(defun (setf user-locale) (locale &optional (session *session*))
  "This function forces the locale for the current user, binding it to the user session,
that is created if no session exists."
  (unless session
    (setf session (claw-start-session)))
  (setf (session-value 'locale session) locale))

(defun validation-errors (&optional (request *request*))
  "Resurns possible validation errors occurred during form rewinding"
  (aux-request-value :validation-errors request))

(defun (setf validation-errors) (value &optional (request *request*))
  "Sets possible validation errors occurred during form rewinding"
  (setf (aux-request-value :validation-errors request) value))

(defun validation-compliances (&optional (request *request*))
  "Resurns the list of components that pass validation during form rewinding"
  (aux-request-value :validation-compliances request))

(defun (setf validation-compliances) (value &optional (request *request*))
  "Sets the list of components that pass validation during form rewinding"
  (setf (aux-request-value :validation-compliances request) value))

(defun add-validation-compliance (id &optional (request *request*))
  "Adds a component id to the list of components that pass validation during form rewinding"
  (setf (validation-compliances request) (nconc (validation-compliances request) (list id))))

(defclass metacomponent (standard-class)
  ()
  (:documentation "This is the meta class the must be set for every WCOMPONENT.
It creates a function whose name is the WCOMPONENT class name plus the character '>'.
The function may then be called as any other claw tag function."))

(defmethod closer-mop:validate-superclass ((class metacomponent)(super standard-class))
  t)


(defun find-first-classdefault-initarg-value (initargs initarg)
  "Returns the first class default init arg value matching matching the given INITARG"
  (loop for current-initarg in initargs
     do (when (eq (first current-initarg) initarg)
          (return (second current-initarg)))))

(defmethod initialize-instance :after ((class metacomponent) &key)
  (let* ((name (class-name class))
         (builder-function (format nil "~a>" name))
         (symbolf (find-symbol builder-function)))
    (unless symbolf
      (setf symbolf (intern builder-function)))
    (setf (fdefinition symbolf) #'(lambda(&rest rest) (build-component name rest)))))

(defun describe-html-attributes-from-class-slot-initargs (class)
  "Helper function that generates documentation for wcomponent init functions"
  (let* ((class-slots (closer-mop:class-direct-slots class)))
    (format nil "~{~%~a~}"
            (remove-if #'null
                       (reverse (loop for slot in class-slots
                                   collect (let ((slot-initarg (first (closer-mop:slot-definition-initargs slot))))
                                             (when slot-initarg
                                               (format nil
                                                       "- :~a ~a"
                                                       slot-initarg
                                                       (documentation slot 't))))))))))

(defvar *id-and-static-id-description* "- :ID The htcomponent-client-id value. CLAW can transform its value to make it univocal
- :STATIC-ID Like the :ID parameter, it sets the htcomponent-client-id instance property, but CLAW will not manage its value to manage its univocity." "Description used for describing :ID and :STATIC-ID used in claw component init functions documentation
")

(defun describe-component-behaviour (class)
  "Returns the behaviour descrioption of a WCOMPONENT init function. If it allows informal parameters, body and the reserved parameters"
  (let* ((initargs (closer-mop:class-default-initargs class))
         (reserved-parameters (find-first-classdefault-initarg-value initargs :reserved-parameters)))
    (format nil "Allows informal parameters: ~a~%Allows body: ~a~%Reserved parameters: ~a"
            (if (find-first-classdefault-initarg-value initargs :allow-informal-parameters)
                "Yes"
                "No")
            (if (find-first-classdefault-initarg-value initargs :empty)
                "No"
                "Yes")
            (if reserved-parameters
                (format nil "~{:~a ~}" (eval reserved-parameters))
                "NONE"))))

(defun register-library-resource (location resource-path &optional content-type external-format)
  "Adds a RESOURCE \(a file or directory) as a library exposed resource to the given relative LOCATION."
  (setf *claw-libraries-resources*
        (sort-by-location (pushnew-location
                           (cons location
                                 (if (directory-pathname-p resource-path)
                                     #'(lambda ()
                                         (let ((resource-full-path (merge-pathnames
                                                                    (uri-to-pathname (subseq (script-name)
                                                                                             (+ (length (clawserver-base-path (current-server)))
                                                                                                (length location))))
                                                                    resource-path)))
                                           (unless (or (null external-format)
                                                       (eq (flexi-streams:external-format-name (reply-external-format))
                                                           (flexi-streams:external-format-name external-format)))
                                             (setf (reply-external-format) external-format))
                                           (handle-static-file resource-full-path content-type)))
                                     #'(lambda () (progn
                                                    (unless (or (null external-format)
                                                                (eq (flexi-streams:external-format-name (reply-external-format))
                                                                    (flexi-streams:external-format-name external-format)))
                                                      (setf (reply-external-format) external-format))
                                                    (handle-static-file resource-path content-type)))))
                           *claw-libraries-resources*))))

(defun uri-to-pathname (uri &optional (relative t))
  "Convert an URI to a pathname"
  (let* ((splitted-uri (split-sequence #\/ uri))
         (directory-list (butlast splitted-uri))
         (file (first (last splitted-uri)))
         (pos (position #\. file :from-end t))
         (file-name-and-type (if (and pos (> pos 0) (string-not-equal (subseq file (1+ pos)) ""))
                                 (list (subseq file 0 pos)(subseq file (1+ pos)))
                                 (list file))))
    (make-pathname :directory (if relative
                                  (cons :relative directory-list)
                                  (cons :absolute directory-list))
                   :name (first file-name-and-type)
                   :type (second file-name-and-type))))