;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE:               web.lisp
;;;;LANGUAGE:           Common-Lisp
;;;;SYSTEM:             Common-Lisp
;;;;USER-INTERFACE:     NONE
;;;;DESCRIPTION
;;;;
;;;;    Allows publishes draw-conses pages.
;;;;
;;;;AUTHORS
;;;;    <PJB> Pascal Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;;    2009-07-10 <PJB> Created.
;;;;BUGS
;;;;LEGAL
;;;;    GPL
;;;;
;;;;    Copyright Pascal Bourguignon 2000 - 2009
;;;;
;;;;    This program is free software; you can redistribute it and/or
;;;;    modify it under the terms of the GNU General Public License
;;;;    as published by the Free Software Foundation; either version
;;;;    2 of the License, or (at your option) any later version.
;;;;
;;;;    This program is distributed in the hope that it will be
;;;;    useful, but WITHOUT ANY WARRANTY; without even the implied
;;;;    warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;;;    PURPOSE.  See the GNU General Public License for more details.
;;;;
;;;;    You should have received a copy of the GNU General Public
;;;;    License along with this program; if not, write to the Free
;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;;    Boston, MA 02111-1307 USA
;;;;**************************************************************************

(in-package "CLAAR-WEB")


(defvar *application-name*               "Common Lisp Ascii Art carveR")
(defvar *application-port*               8006)
(defvar *email*                          "pjb@informatimago.com")

(defvar *home-uri*
  (format  nil "http://claar.informatimago.com:~D/" *application-port*)
  "URL of the main web site.")


(defparameter *utf-8*
  (flex:make-external-format :utf-8 :eol-style :lf)
  "The UTF-8 encoding.")

(defparameter *spaces*
  #(#\space #\tab #\newline #\linefeed #\return #\vt #\formfeed)
  "A bag of spaces.")


(defun drawing-uri (path)
  (format nil "~A~A" *home-uri* path))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defun pathname-items (pname)
  (append (pathname-directory pname)
          (list (file-namestring pname))))

(defun remove-base (BASE PATH)
  (LET* ((P (CONS :RELATIVE (SUBSEQ (PATHNAME-ITEMS PATH)
                                    (MISMATCH (PATHNAME-ITEMS BASE)
                                              (PATHNAME-ITEMS PATH)
                                              :test (function equal)))))
         (F (CAR (LAST P))))
    (MAKE-PATHNAME :DIRECTORY (BUTLAST P)
                   :NAME (PATHNAME-NAME F)
                   :TYPE (PATHNAME-TYPE F))))


(defun format-date (universal-time)
  (multiple-value-bind (se mi ho da mo ye)
      (decode-universal-time universal-time)
    (format nil "~2@*~4,'0D-~1@*~2,'0D-~0@*~2,'0D ~3@*~2,'0D:~2,'0D:~2,'0D"
            da mo ye  ho mi se)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defparameter *database*
  (make-array 8 :adjustable t :fill-pointer 0)
  "A vector of drawings.")

(defstruct entry date-created owner drawing)

(defun db-insert (entry)
  (vector-push-extend entry *database*))

(defun db-insert-drawing (owner drawing)
  (db-insert  (make-entry :date-created (get-universal-time)
                          :owner owner
                          :drawing drawing)))

(defun db-query (index)
  (when (< index (length *database*))
    (aref *database* index)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;


(defmacro with-app-page ((&key (title *application-name*)
                               logo-url logo-alt
                               head) &body body)
  (WITH-GENSYMS (vlogo-url vlogo-alt)
    `(with-output-to-string (*html-output-stream*)

       (let ((,vlogo-url ,logo-url)
             (,vlogo-alt ,logo-alt))
         (declare (ignorable ,vlogo-url ,vlogo-alt))
         (with-html-output (*html-output-stream* :encoding "UTF-8" :kind :html)
           (doctype
             :loose
             (html ()
                   (head ()
                         (title () (pcdata "~A" ,title))
                         (meta (:http-equiv "Content-Type"
                                            :content "text/html; charset=utf-8"))
                         ;; (link (:rel "stylesheet"
                         ;;             :href (common-resources-uri "css/films.css")
                         ;;             :type "text/css"))
                         ,@head)
                   (body (:class "claar")
                         (div (:id "content")
                             ,@body)))))))))


(defmacro reporting-errors (&body body)
  `(handler-bind
       ((error (lambda  (err)
                 (with-app-page (:title "Error")
                   (hunchentoot:log-message :error "Got an error: ~A" err)
                   (dolist (frame (SB-DEBUG:BACKTRACE-AS-LIST))
                     (hunchentoot:log-message :error "Backtrace: ~S" frame))
                   (pcdata "Got an error: ~A" err)
                   (table ()
                          (dolist (frame (SB-DEBUG:BACKTRACE-AS-LIST))
                            (tr () (td () (code () (pcdata "~S" frame))))))))))
     (progn ,@body)))


(defun make-form (enctype action form-key-and-values other-key-and-values body)
  `(form (:action ,action
                  :method "POST"
                  :accept-charset :utf-8
                  :enctype ,enctype
                  ,@form-key-and-values)
         ,@(loop
              :for (key value) :on other-key-and-values :by (function cddr)
              :collect `(input (:type "hidden"
                                      :name ,(string-downcase key)
                                      :value ,value)))
         ,@body))


(defmacro insert-form ((action (&rest form-key-and-values &key &allow-other-keys)
                               &rest other-key-and-values &key &allow-other-keys)
                       &body body)
  (make-form "application/x-www-form-urlencoded"
             action
             form-key-and-values
             other-key-and-values
             body))


(defmacro insert-file-form ((action (&rest form-key-and-values &key &allow-other-keys)
                                    &rest other-key-and-values &key &allow-other-keys)
                            &body body)
  (make-form "multipart/form-data"
             action
             (list* :id "upload" :name "upload" form-key-and-values)
             other-key-and-values
             body))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;



(defun home ()
  (reporting-errors
   (let* ((uri (hunchentoot:request-uri hunchentoot:*request*))
          (index (and (< 1 (length uri))
                      (char= #\/ (aref uri 0))
                      (parse-integer uri :start 1 :junk-allowed nil)))
          (entry (when index (db-query index))))
     (with-app-page (:title "CLAAR")
       (cond
         ((null index)
          (p ()
             (pcdata "Invalid URI ~S.  Try again." uri)))
         ((null entry)
          (p ()
             (pcdata "No data at URI ~S yet.  Try again later." uri)))
         (t
          (pre ()
               (cdata (format nil "Date: ~A~%From: ~A~2%~A"
                              (format-date (entry-date-created entry))
                              (entry-owner entry)
                              (entry-drawing entry))))))))))


(defun initialize ()
  ;; (load-databases)
  ;; (setf (hunchentoot:log-file) (in-log "publish-files.log"))
  )


(defun create-dispatcher (script-name page-function)
  "Creates a dispatch function which will dispatch to the
function denoted by PAGE-FUNCTION if the file name of the current
request is PATH."
  (lambda (request)
    (and (string= (hunchentoot:script-name request) script-name)
         page-function)))


(defvar *server* nil)


(defun start-claar-server ()
  (initialize)
  (setf hunchentoot:*HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT*  *utf-8*
        hunchentoot:*DEFAULT-CONTENT-TYPE* "text/html; charset=UTF-8")
  (setf hunchentoot:*dispatch-table*
        `(
          ,(lambda (request) (declare (ignore request)) 'home)
           ;; ,@(mapcar
           ;;    (lambda (args) (apply (function create-dispatcher) args))
           ;;    '(("/"                              get-art)
           ;;      ;; ("/publish-new-file"              publish-new-file)
           ;;      ))
           ;; ,(hunchentoot:create-static-file-dispatcher-and-handler
           ;;   "/scripts/upload-film.js"
           ;;   (in-document-root "scripts/upload-film.js")
           ;;   "text/javascript")
           ;; ,(function hunchentoot:default-dispatcher)
          ))
  #-(and)
  (setf *server* (hunchentoot:start-server :port *application-port*))
  (setf *server* (make-instance 'hunchentoot:acceptor :port  *application-port*))
  (bordeaux-threads:make-thread (lambda () (hunchentoot:start *server*))
                                :name "Hunchentoot Web Server"))


(defun stop-claar-server ()
  (hunchentoot:stop *server*)
  (setf *server* nil))


;; (progn
;;   (create-initial-clients)
;;   (shell "htpasswd -b -c ~A ~A ~A" (in-etc "passwords") "henry" "roger")
;;   (database-map *client-database* (lambda (k v) (initialize-client-directory v)))
;;   (set-access-rights)
;;   (COM.INFORMATIMAGO.COMMON-LISP.FILE:TEXT-FILE-CONTENTS (in-etc "passwords")))

;; (progn(load"publish-files.lisp")(load-databases))
ViewGit