;;; --------------------------------------------------------------------
;;; Lisp Server Pages (LSP) -- Implements something like Java Server
;;; Pages (JSP), but for Lisp.
;;;
;;; Copyright 2001, 2002 I/NET Inc. (http://www.inetmi.com/)
;;; John Wiseman (jjwiseman@yahoo.com)
;;; 2002-06-10
;;;
;;; Ported to hunchentoot by Mac Chan
;;; 2007-05-22
;;;
;;; Licensed under the MIT license

(in-package #:cl-user)

(defpackage #:lsp
  (:use #:cl #:hunchentoot)
  (:export #:clear-lsp-cache
           #:create-lsp-folder-dispatcher-and-handler
           #:do-lsp-request
           #:get-lsp-function
           #:set-lsp-content-type
           #:set-lsp-debug
           #:set-lsp-package
           #:show-lsp-form
           #:enable-debug-mode
           #:disable-debug-mode))

(in-package :lsp)

(defparameter *this-dir*
  (load-time-value
   (make-pathname :name nil :type nil :version nil :defaults
                  (or #.*compile-file-pathname* *load-pathname*))))

(defvar *lsp-package* nil
  "If set, this is the package used for all unqualified symbols in lsp
files")

(defun set-lsp-package (package)
  (setq *lsp-package* (find-package package)))

(defvar *default-content-type* "text/html"
  "if we cannot determine the content type from the pathname-type,
we'll use this as the default content-type")

(defun set-lsp-content-type (content-type)
  (setq *default-content-type* content-type))

(defparameter *debug* nil
  "Control whether to save intermidate lisp-form for debugging.")

(defun set-lsp-debug (bool)
  (setq *debug* bool))

;; See http://www.emmett.ca/~sabetts/slurp.html
(defun contents-of-file (pathname)
  "Returns a string with the entire contents of the specified file."
  (with-open-file (in pathname :direction :input)
    ;; We'll probably be making a bigger string than necessary because
    ;; of the UTF-* encoding, cr/lf -> newline conversions, etc.  so
    ;; we need to initialize the string with #\space or we'll see
    ;; random garbage in the output
    (let ((seq (make-string (file-length in) :initial-element #\space)))
      (read-sequence seq in)
      seq)))

;; stealed from arnesi
(defun ensure-list (thing)
  "Returns THING as a list.

If THING is already a list (as per listp) it is returned,
otherwise a one element list containing THING is returned."
  (if (listp thing)
      thing
      (list thing)))

(defstruct lsp-struct
  pathnames
  timestamp
  func
  lisp-form)

(defun outdated (struct)
  (let ((ts (lsp-struct-timestamp struct)))
    (loop for d in (lsp-struct-pathnames struct) thereis
          (> (file-write-date d) ts))))

(defvar *lsp-functions* (make-hash-table :test #'equal)
  "The table mapping LSP filespecs to lsp-struct.")

(defun clear-lsp-cache (&optional file)
  "Remove a function cache keyed by file from the cache.  If file is
not supplied, we take that the user want to remove all the contents of
the cache."
  (if file
      (remhash (pathname file) *lsp-functions*)
      (setq *lsp-functions* (make-hash-table :test #'equal))))

(defun register-lsp-function (files function &optional lisp-form)
  "Insert a compiled function into the cache"
  (let ((files (ensure-list files)))
    (setf (gethash (first files) *lsp-functions*)
          (apply #'make-lsp-struct :pathnames files
                 :timestamp (loop for f in files maximizing (file-write-date f))
                 :func function
                 ;; don't waste memory for the intermidate lisp-form
                 ;; unless we need to debug
                 (and *debug* (list :lisp-form lisp-form)))))
  (values function))

(defun show-lsp-form (file)
  "Show the lisp form we compiled from file for debugging."
  (let ((struct (gethash file *lsp-functions*)))
    (when struct
      (pprint (lsp-struct-lisp-form struct)))))

;; Given a tag type (:scriptlet or :expression), returns a format
;; string to be used to generate source code from the contents of the
;; tag.

(defun tag-template (tag-type)
  (ecase tag-type
    ((:scriptlet) "~A")
    ((:expression) "(princ ~A)")))

;; Finds the next scriptlet or expression tag in LSP source.  Returns
;; nil if none are found, otherwise returns 3 values:
;;  1. The position of the opening bracket (<) of the tag.
;;  2. The position of the contents of the tag.
;;  3. The type of tag (:scriptlet or :expression).

(defun next-code (string start)
  (let ((start-tag (search "<%" string :start2 start)))
    (if (not start-tag)
        nil
        (if (and (> (length string) (+ start-tag 2))
                 (eql (char string (+ start-tag 2)) #\=))
            (values start-tag (+ start-tag 3) :expression)
            (values start-tag (+ start-tag 2) :scriptlet)))))

;; (i) Converts text outside <% ... %> tags (straight HTML) into calls
;; to net.html.generator.html, (ii) Text inside <% ... %>
;; ("scriptlets") is straight lisp code, (iii) Text inside <%= ... %>
;; ("expressions") becomes the body of the net.html.generator:html
;; macro.

(defun construct-lsp-body-string (lsp-string &optional (start 0))
  "Takes a string containing an LSP page and returns a string
   containing the lisp code that implements that page."
  (multiple-value-bind (start-tag start-code tag-type)
      (next-code lsp-string start)
    (if (not start-tag)
        (format nil "(princ ~S)" (subseq lsp-string start))
        (let ((end-code (search "%>" lsp-string :start2 start-code)))
          (if (not end-code)
              (error "EOF reached in LSP inside open '<%' tag.")
              (progn
                (format nil "(princ ~S) ~A ~A"
                        (subseq lsp-string start start-tag)
                        (format nil (tag-template tag-type)
                                (subseq lsp-string start-code end-code))
                        (construct-lsp-body-string lsp-string (+ end-code 2)))))))))

(defun construct-lsp-function (lsp-string)
  "Builds and compiles the request-handling LSP function for the page
   whose contents are in LSP-STRING."
  (let ((form 
         `(lambda (&optional request &rest args)
           (declare (ignorable args request))
           (with-output-to-string (*standard-output*)
             ;; We punt hard on the issue of package.
             ,(let ((*package* (or *lsp-package* *package*)))
                   (read-from-string
                    (format nil "(progn ~a)"
                            (construct-lsp-body-string lsp-string))))))))
    (values (compile nil form) form)))

;; As much as I hate to throw regex at the problem, the semantics of
;; cl-ppcre:regex-replace-all is just a nice fit to this task.
;; This is not the critical path, anyway :-)
(defun lsp-file->string (file)
  "Read contents of file and insert in-place for any #include files we
found. Returns the result string and the list of include files."
  (let* ((file (pathname file))
         (include-files))
    (values
     (cl-ppcre:regex-replace-all
      ;; <!--#include file="footer.inc"-->
      "<!--\\s*#include\\s+file=\"([^\"]+)\"\\s*-->"
      (contents-of-file file)
      #'(lambda (match &rest registers)
          (declare (ignore match))
          (let ((include-file (merge-pathnames (elt registers 0) file)))
            (pushnew include-file include-files)
            (multiple-value-bind (content more-files)
                (lsp-file->string include-file)
              (dolist (f more-files)
                (pushnew f include-files))
              (values content))))
      :simple-calls t)
     include-files)))

(defun get-lsp-function (file)
  "Returns the function implementing a given LSP file.  Builds and
   compiles the function the first time it's requested, or if the file
   has been modified."
  (let* ((file (pathname file))         ;normalize
         (struct (gethash file *lsp-functions*)))
    (if (or (null struct) (outdated struct))
        (multiple-value-bind (content include-files)
            (lsp-file->string file)
          (multiple-value-bind (func lisp-form)
              (construct-lsp-function content)
            (register-lsp-function (cons file include-files) func lisp-form)))
        (lsp-struct-func struct))))

(defun do-lsp-request (file &optional
                       (request
                        #+hunchentoot
                        (and (boundp 'hunchentoot:*request*) hunchentoot:*request*)))
  "Call a lsp function \(output to *standard-output*)" 
  (funcall (get-lsp-function file) request))


(defun file-size (file)
  "Returns filesize in bytes, or NIL if it is a directory."
  (cl:ignore-errors
    (with-open-file (in file :direction :input)
      (file-length in))))

(defstruct file-details name date size (desc "" :type string))

(defun file-date-string (file-details)
  "Returns a descriptive string like \"15-Feb-2007\"."
  (multiple-value-bind
        (second minute hour date month year)
      (decode-universal-time (file-details-date file-details))
    (declare (ignore second minute hour))
    (let ((month-names
           '("Jan" "Feb" "Mar" "Apr" "May" "Jun"
             "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")))  
      (format nil "~2,'0d-~A-~D"
              date (nth (1- month) month-names) year))))

(defun file-size-string (file-details)
  "Returns a descriptive string like \"1.3K\" or \"8M\"."
  (let ((size (file-details-size file-details)))
    (cond ((not (numberp size)) "-&nbsp;")
          ((< size 1024) (format nil "~D&nbsp;" size))
          ((< size (* 1024 1024)) (format nil "~,1FK" (/ size 1024)))
          (t (format nil "~,1FM" (/ size (* 1024 1024)))))))

(defun maybe-integer-lessp (a b)
  "If both a & b are numbers, then it's just like #'<
Otherwise, non number goes first."
  (cond ((and (numberp a) (numberp b))
         (< a b))
        ((numberp b) t)
        (t nil)))

(defun sort-file-details (list &optional (sort-column "N") (sort-order "A"))
  "Sort file-details based on sort column and order."
  (let* ((sort-column (intern sort-column :keyword))
         (compare-func
          (ecase sort-column
            ((:M :S) #'maybe-integer-lessp)
            ((:N :D) #'string-lessp)))
         (selector
          (ecase sort-column
            (:N #'file-details-name)
            (:M #'file-details-date)
            (:S #'file-details-size)
            (:D #'file-details-desc)))
         (results (sort list compare-func :key selector)))
    (if (string-equal sort-order "D")
        (nreverse results)
        results)))

(defun redirect-if-malformed-pathspec ()
  "Directory listing request should end in a forward slash like
\"http://localhost/hunchentoot/code/\". Fix it if it is not the
case."
  (let* ((script-name (hunchentoot:script-name))
         (length (length script-name)))
    (unless (and (> length 0)
                 (char= (aref script-name (1- length)) #\/))
      ;; stripping the query string is OK
      (hunchentoot:redirect (concatenate 'string script-name "/")))))

(defun folder-index-page (pathname)
  "Returns a html page with a directory listing like those generated
by Apache."
  (redirect-if-malformed-pathspec)
  (let* ((contents (cl-fad:list-directory (namestring pathname)))
         (title (format nil "Index of ~A" (hunchentoot:script-name)))
         (sort-column (hunchentoot:get-parameter "C"))
         (sort-order (hunchentoot:get-parameter "O")))
    (flet ((file-details (file)
             (make-file-details :name (cl-ppcre:regex-replace "\\\\$"
                                       (enough-namestring file pathname)
                                       "/")
                                :date (file-write-date file)
                                :size (file-size file))))
      ;; taint get-parameters
      (unless (member sort-column '("N" "M" "S" "D") :test #'string-equal)
        (setq sort-column "N"))
      (unless (member sort-order '("A" "D") :test #'string-equal)
        (setq sort-order "A"))
      ;; page-out
      (with-output-to-string (out)
        (format out "<html><head><title>~A</title>
	<style type=\"text/css\">
	<!--
        .size { text-align: right; }
	th { padding: 0.2em; text-align: left; }
	td { padding: 0.2em; }
	table { font-family: monospace;	}
	-->
	</style></head><body><h1>~A</h1><table><tr>" title title)
        ;; column headers
        (loop for (query-char desc) in
              '(("N" "Name")
                ("M" "Last modified")
                ("S" "Size")
                ("D" "Description")) do
                (format out "<th><a href=\"?C=~A&O=~A\">~A</a></th>"
                        query-char
                        (or (when (string-equal query-char sort-column)
                              (if (string-equal sort-order "D") "A" "D"))
                            "A")
                        desc))
        (format out "</tr><tr><td colspan=\"4\"><hr/></td></tr><tr>
                     <td><a href=\"../\">Parent Directory</a></td>
                     <td></td><td></td><td></td></tr>")
        (dolist (d (sort-file-details
                    (mapcar #'file-details contents)
                    sort-column sort-order))
          (format out "<tr><td><a href=\"~A\">~A</a></td>"
                  (file-details-name d) (file-details-name d))
          (format out "<td>~A</td><td class=\"size\">~A</td><td>~A</td></tr>"
                  (file-date-string d)
                  (file-size-string d) 
                  (file-details-desc d)))
        (format out "<tr><td colspan=\"4\"><hr/></td></tr></table>
                     <p>~A</p></body></html>" (hunchentoot::address-string))))))

(defun throw-bad-return-code (return-code)
  (setf (hunchentoot:return-code) return-code)
  (throw 'hunchentoot:handler-done nil))

(defun create-lsp-folder-dispatcher-and-handler
    (uri-prefix base-path
     &key
     lsp-file-types                     ; '("lsp")
     inc-file-types                     ; '("inc")
     folder-index-page
     (http-not-found-handler
      (lambda (&optional pathname)
        (declare (ignore pathname))
        (throw-bad-return-code hunchentoot:+http-not-found+)))
     before-handler
     content-type)
  "Creates and returns a dispatch function which will dispatch to a
handler function which emits the file relative to BASE-PATH that is
denoted by the URI of the request relative to URI-PREFIX.  URI-PREFIX
must be a string ending with a slash, BASE-PATH must be a pathname
designator for an existing directory.  If CONTENT-TYPE is not NIL,
it'll be the content type used for all static files in the folder.

If pathname-type of the static file matches one of the
LSP-FILE-TYPES The file will be compiled to a function and cached
by lsp. This function executes and returns a string to the browser.

If pathname-type of the static file matches one of the INC-FILE-TYPES,
the handler will return \(these are the include files not meant to be
rendered on their own)

If FOLDER-INDEX-PAGE is T, a directory listing page \(like apache's)
is shown when the script-name corresponds to a directory in the
base-path

If the static file is not found in the filesystem, by default we'll
return +http-not-found+ to the browser. If HTTP-NOT-FOUND-HANDLER is
supplied, it should be a function that takes an optional argument
\(pathname) that will handle the situation \(by either return a
user-friendly page or logging / etc)

If before-handler is supplied, for each request it will be invoked. If
this handler returns non-NIL, the result will be send to the browser
instead. This can be useful for password protecting important files,
etc."
  (unless (and (stringp uri-prefix)
               (plusp (length uri-prefix))
               (char= (char uri-prefix (1- (length uri-prefix))) #\/))
    (error "~S must be string ending with a slash." uri-prefix))
  (when (or (pathname-name base-path)
            (pathname-type base-path))
    (error "~S is supposed to denote a directory." base-path))
  ;; this will signal an error if path doesn't exist
  (let ((base-path (truename base-path)))
    (flet ((handler ()
             (let* ((script-name (hunchentoot:url-decode (hunchentoot:script-name)))
                    (script-path (enough-namestring (cl-ppcre:regex-replace-all "\\\\" script-name "/")
                                                    uri-prefix))
                    (script-path-directory (pathname-directory script-path)))
               (unless (or (stringp script-path-directory)
                           (null script-path-directory)
                           (and (listp script-path-directory)
                                (eq (first script-path-directory) :relative)
                                (loop for component in (rest script-path-directory)
                                      always (stringp component))))
                 (throw-bad-return-code hunchentoot:+http-forbidden+))
               (let* ((pathname (merge-pathnames script-path base-path))
                      (pathname-type (pathname-type pathname)))
                 (or (and before-handler (funcall before-handler pathname))
                     (cond ((not (probe-file pathname))
                            (when http-not-found-handler
                              (funcall http-not-found-handler pathname)))
                           ((member pathname-type lsp-file-types :test #'string-equal)
                            (setf (hunchentoot:content-type)
                                  (or (hunchentoot:mime-type pathname)
                                      *default-content-type*))
                            (funcall (get-lsp-function pathname) hunchentoot:*request*))
                           ((member pathname-type inc-file-types :test #'string-equal)
                            (throw-bad-return-code hunchentoot:+http-forbidden+))
                           ((and folder-index-page pathname 
                                 (cl-fad:directory-pathname-p pathname))
                            (folder-index-page pathname))
                           (t
                            (hunchentoot:handle-static-file pathname content-type))))))))
      (hunchentoot:create-prefix-dispatcher uri-prefix #'handler))))

(let (#-(and)
        (saved-process-connection #'hunchentoot::process-connection)
      (saved-process-request #'hunchentoot::process-request)
      last-server last-request last-session)

  (defun show-stuff ()
    (list last-server last-request last-session))
  
  (defun request-sniffer (request)
    (setf last-server *server*
          last-request request
          last-session *session*)
    (values))

  (defun enable-debug-mode ()
    "Set the top-level *request* and *session* var to the last
dynamically bound values"
    ;; if enable-debug-mode is called more than once, make sure only
    ;; one #'request-sniffer is in dispatch-table and that it is the
    ;; first one in the table
    (setf *dispatch-table*
          (cons #'request-sniffer
                (delete #'request-sniffer *dispatch-table*))
          #-(and)
          (fdefinition 'hunchentoot::process-connection)
          #-(and)
          #'(lambda (&rest args)
              (prog1 (apply saved-process-connection args)
                (setq *server* last-server)))
          (fdefinition 'hunchentoot::process-request)
          #'(lambda (&rest args)
              (prog1 (apply saved-process-request args)
                (setq *request* last-request
                      *session* last-session)))))  

  (defun disable-debug-mode ()
    "Undo the changes by enable-debug-mode."
    (makunbound '*server*)
    (makunbound '*request*)
    (makunbound '*session*)
    (setf last-request nil last-session nil
          *dispatch-table* (delete #'request-sniffer *dispatch-table*)
          #-(and)
          (fdefinition 'hunchentoot::process-connection)
          #-(and)
          saved-process-connection
          (fdefinition 'hunchentoot::process-request) saved-process-request))

  (defun debug-set-server ()
    (setq *server* last-server)))