(defpackage "COLESLAW-GUI"
  (:use "CLIM-LISP"))
(in-package "COLESLAW-GUI")


;;; Embrace the chaos

(defmacro with-current-directory ((path value) &body body)
  `(let* ((,path (cl-fad:pathname-as-directory ,value))
          (*default-pathname-defaults* ,path))
     (ensure-directories-exist ,path)
     (uiop:chdir ,path)
     ,@body))

;;; Allow for passing "env" here.
(defun blog-key (blog)
  (etypecase blog
    (null nil)
    (cons (coleslaw:repo-dir (first blog)))
    (coleslaw::blog (coleslaw:repo-dir blog))))

(defun blog () coleslaw:*config*)
(defun site () coleslaw::*site*)

(defun make-null-env ()
  (list nil (make-hash-table :test #'equal)))

(defun copy-blog-env ()
  (list coleslaw:*config*
        coleslaw::*site*))

(defun load-blog-env (env)
  (destructuring-bind (blog site)
      (or env (make-null-env))
    (setf coleslaw:*config* blog
          coleslaw::*site* site)
    ;; Populates *ALL-TAGS* and *ALL-MONTHS* using *SITE*.
    (coleslaw::update-content-metadata)))

(defun save-blog-env (table)
  (when table
    (setf (gethash (blog-key coleslaw:*config*) table)
          (copy-blog-env))))

(defmacro with-blog-env ((env table) &body body)
  `(let (coleslaw:*config*
         coleslaw::*site*)
     (load-blog-env ,env)
     (multiple-value-prog1 (progn ,@body)
       (save-blog-env ,table))))


;;; Presentations

(clim:define-presentation-type coleslaw::blog ()
  :description "(Configuration)")

(clim:define-presentation-type blog-env ()
  :description "(Blog)")

(clim:define-presentation-method clim:present
    (self (type coleslaw::blog) stream (view clim:textual-view) &key acceptably for-context-type)
  (declare (ignore view acceptably for-context-type))
  (format stream "~a" (blog-key self)))

(clim:define-presentation-method clim:present
    (env (type blog-env) stream (view clim:textual-view) &key acceptably for-context-type)
  (declare (ignore acceptably for-context-type))
  (with-blog-env (env nil)
    (princ "[" stream)
    (clim:present (blog) 'coleslaw::blog :stream stream :view view)
    (princ "]" stream)))


;;; Managing a blog collection

(clim:define-application-frame coleslaw-cli ()
  ((envs :initform (make-hash-table :test #'equal) :reader envs)))

(clim:define-command (com-open-blog :name t :command-table coleslaw-cli)
    ((directory 'pathname))
  (clim:with-application-frame (frame)
    (with-current-directory (path directory)
      (with-blog-env (nil (envs frame))
        (format *query-io* "Opening a blog in ~s.~%" path)
        (coleslaw::load-config path)))))

(clim:define-command (com-make-blog :name t :command-table coleslaw-cli)
    ((directory 'pathname))
  (clim:with-application-frame (frame)
    (with-current-directory (path directory)
      (with-blog-env (nil (envs frame))
        (format *query-io* "Creating a new blog in ~s. " path)
        (coleslaw-cli:setup)
        (coleslaw::load-config path)))))

(clim:define-command (com-list-blogs :name t :command-table coleslaw-cli)
    ()
  (clim:with-application-frame (frame)
    (dolist (env (alexandria:hash-table-values (envs frame)))
      (clim:present env 'blog-env :stream (clim:frame-query-io frame)
                                  :single-box t)
      (terpri (clim:frame-query-io frame)))))

(clim:define-command (com-close-blog :name t :command-table coleslaw-cli)
    ((self 'blog-env))
  (clim:with-application-frame (frame)
    (remhash (blog-key self) (envs frame))))

(clim:define-command (com-stage-blog :name t :command-table coleslaw-cli)
    ((self 'blog-env))
  (clim:with-application-frame (frame)
    (with-current-directory (path (blog-key self))
      (with-blog-env (self (envs frame))
        (format *query-io* "Staging the blog from ~s. " path)
        (coleslaw-cli:stage)))))

(clim:define-command (com-deploy-blog :name t :command-table coleslaw-cli)
    ((self 'blog-env))
  (clim:with-application-frame (frame)
    (with-current-directory (path (blog-key self))
      (with-blog-env (self (envs frame))
        (format *query-io* "Deploying the blog from ~s. " path)
        (coleslaw-cli:deploy)))))

(clim:define-command (com-spam-blogs :name t :command-table coleslaw-cli)
    ()
  (dotimes (i 8)
    (let ((d (format nil "/tmp/blogs/specimen-~2,'0d/" i)))
      (if (probe-file d)
          (com-open-blog d)
          (with-current-directory (path d)
            (com-make-blog d)
            ;; Without any content "Stage" and "Deploy" will fail.
            (coleslaw-cli:new))))))

(clim:define-command (com-clear :name t :command-table coleslaw-cli)
    ()
  (clim:with-application-frame (frame)
    (clim:window-clear (clim:frame-query-io frame))))

(macrolet ((def (name command short-description long-description)
             `(clim:define-presentation-to-command-translator ,name
                  (blog-env ,command coleslaw-cli
                   :gesture nil
                   :documentation ,short-description
                   :pointer-documentation ,long-description)
                  (self)
                `(,self))))
  (def trn-close-blog  com-close-blog  "Close"  "Remove blog from collection")
  (def trn-stage-blog  com-stage-blog  "Stage"  "Compile blog to staging area")
  (def trn-deploy-blog com-deploy-blog "Deploy" "Compile blog to production"))

(clim:define-presentation-method clim:accept
    ((type blog-env) stream (view clim:textual-view) &rest args)
  (declare (ignore args))
  (clim:with-application-frame (frame)
    (clim:completing-from-suggestions (stream)
      (maphash (lambda (key val)
                 (clim:suggest (namestring key) val))
               (envs frame)))))


;;; Managing a blog instance

(defun display (object stream)
  (clim:present object (clim:presentation-type-of object) :stream stream))

(defun present* (object stream)
  (clim:present object (clim:presentation-type-of object) :stream stream))

(defmacro dohash (((key val) hash &optional result) &body body)
  (let ((cont (gensym)))
    `(flet ((,cont (,key ,val) ,@body))
       (declare (dynamic-extent (function ,cont)))
       (maphash (function ,cont) ,hash)
       ,result)))

(defun format-today ()
  (local-time:format-timestring nil (local-time:now)
                                :format '((:year 4) "-" (:month 2) "-" (:day 2) "-"
                                          (:hour 2) "-" (:min 2) "-" (:sec 2))))

;;; KLUDGE: FANCY-VIEW extends (not specializes) the TEXTUAL-VIEW.
(defclass fancy-view (clim:textual-view) ())
(defvar +fancy-view+ (make-instance 'fancy-view))

(clim:define-application-frame coleslaw-gui (coleslaw-cli)
  ((current-blog :initform nil :accessor current-blog))
  (:command-table (coleslaw-gui :inherit-from (coleslaw-cli)))
  (:reinitialize-frames t)
  (:panes (app :application :display-function 'display :default-view +fancy-view+
               :text-margins '(:left 20 :top 10))
          (int :interactor)))

(clim:define-command (com-update :command-table coleslaw-gui)
    ((self 'blog-env))
  (clim:with-application-frame (frame)
    (with-current-directory (path (blog-key self))
      (with-blog-env (self (envs frame))
        ;; This function removes content from *site* before adding it back.
        (coleslaw::load-content)))))

(clim:define-command (com-select :command-table coleslaw-gui)
    ((self 'blog-env))
  (clim:with-application-frame (frame)
    (setf (current-blog frame) self)
    (com-update self)))

(clim:define-command (com-create :name t :command-table coleslaw-cli)
    ((self 'blog-env)
     (type 'string :default "post")
     (name 'string :default (format-today)))
  (clim:with-application-frame (frame)
    (with-current-directory (path (blog-key self))
      (with-blog-env (self (envs frame))
        ;; This function removes content from *site* before adding it back.
        (coleslaw-cli:new type name)
        (com-update self)))))

(macrolet ((def (name command gesture short-description long-description)
             `(clim:define-presentation-to-command-translator ,name
                  (blog-env ,command coleslaw-gui
                   :gesture ,gesture
                   :documentation ,short-description
                   :pointer-documentation ,long-description)
                  (self)
                `(,self))))
  (def trn-update com-update nil     "Update"  "Update blog from disk")
  (def trn-select com-select :select "Select"  "Show blog details")
  (def trn-create com-create nil     "Create"  "Create new content"))

(clim:define-presentation-method clim:present
    ((frame coleslaw-gui) (type coleslaw-gui) stream (view fancy-view) &rest args)
  (declare (ignore args))
  (clim:formatting-item-list (stream)
   (dohash ((dir env) (envs frame))
     (declare (ignore dir))
     (clim:formatting-cell (stream)
       (clim:with-drawing-options (stream :ink (if (eql env (current-blog frame))
                                                   clim:+dark-red+
                                                   clim:+foreground-ink+))
         (clim:present env 'blog-env :stream stream :view clim:+textual-view+ :single-box t)))))
  (terpri stream)
  (clim:present (current-blog frame) 'blog-env :stream stream :view view
                                               :sensitive nil
                                               :allow-sensitive-inferiors t))


(clim:define-presentation-type coleslaw::index ()
  :description "(Index)")

(clim:define-presentation-type site ()
  :description "(Site)")

(clim:define-presentation-type post ()
  :description "(Post)")

(clim:define-presentation-type post ()
  :description "(Page)")

(defun gap-the-gap (stream command label color)
  (clim:with-output-as-presentation (stream command '(clim:command :command-table coleslaw-gui))
    (clim:with-room-for-graphics (stream :first-quadrant nil)
      (clim:draw-circle* stream 0 0 40 :ink clim:+dark-red+ :filled nil :line-thickness 20)
      (clim:surrounding-output-with-border (stream :filled t :ink color)
        (clim:draw-text* stream label 0 0 :align-x :center :align-y :center
                                          :text-size :small
                                          :text-family :fix
                                          :ink clim:+white+)))))

(clim:define-presentation-method clim:present
    ((self cons) (type blog-env) stream (view fancy-view) &rest args)
  (declare (ignore args))
  (clim:with-application-frame (frame)
    (with-blog-env (self (envs frame))
      ;; Blog title
      (clim:with-text-style (stream (clim:make-text-style :serif :bold :large))
        (format stream "~a" (coleslaw:title (blog))))
      (terpri stream)
      ;; Update the blog bleeper
      (gap-the-gap stream `(com-update ,self) "Mind the gap!" clim:+dark-blue+)
      (princ " " stream)
      (gap-the-gap stream `(com-create ,self "post" ,(format-today)) "Fill the gap!" clim:+dark-green+)
      (princ " " stream)
      (gap-the-gap stream `(com-create ,self "page" ,(format-today)) "Keep the gap!" clim:+dark-red+)
      (terpri stream)
      ;; The content
      (clim:present (site) 'site :stream stream :view view))))

(clim:define-presentation-method clim:present
    (self (type site) stream (view fancy-view) &rest args)
  (declare (ignore args))
  (clim:formatting-table (stream)
   (dohash ((key val) self)
     (clim:formatting-row (stream)
       (clim:formatting-cell (stream) (present* key stream))
       (clim:formatting-cell (stream) (present* val stream))))))

(clim:define-presentation-action act-open-content
    (coleslaw::content nil coleslaw-gui
     :documentation "Open file"
     :pointer-documentation "Open the content file")
    (object)
  (uiop:launch-program (format nil "xdg-open ~a" (coleslaw::content-file object))))

(clim:define-presentation-action act-kill-content
    (coleslaw::content nil coleslaw-gui
     :documentation "Kill file"
     :pointer-documentation "Kill the content file")
    (object)
  (clim:with-application-frame (frame)
    (with-current-directory (dir (blog-key (current-blog frame)))
      (uiop:launch-program (format nil "rm ~a" (coleslaw::content-file object))))
    (clim:execute-frame-command frame `(com-update ,(current-blog frame)))))

(clim:define-presentation-action act-inspect
    ((or coleslaw::blog coleslaw::content coleslaw::feed coleslaw::index) nil coleslaw-gui
     :gesture nil
     :documentation "Inspect content"
     :pointer-documentation "Inspect site content")
  (object)
  (clouseau:inspect object :new-process t))


;;; Big ball of mud

(clim:define-application-frame durk (coleslaw-gui)
  ((acceptor :initarg :acceptor :accessor acceptor))
  (:panes
   (app :application :display-function 'display :default-view +fancy-view+)
   (int :interactor :height 100))
  (:reinitialize-frames t)
  (:command-table (durk :inherit-from (coleslaw-gui)))
  (:default-initargs :acceptor nil))

;;; We could enable and disable commands by calilng (SETF CLIM:COMMAND-ENABLED).
(defmethod clim:command-enabled (name (frame durk))
  (case name
    (com-stop-acceptor (hunchentoot:started-p (acceptor frame)))
    (com-start-acceptor (not (hunchentoot:started-p (acceptor frame))))
    (otherwise (call-next-method))))

(defmethod clim:adopt-frame :after (fm (self durk))
  (format *debug-io* "Booting up.~%")
  (setf (acceptor self) (make-instance 'hunchentoot:easy-acceptor :port 4242))
  (setf hunchentoot:*dispatch-table*
        (list (hunchentoot:create-static-file-dispatcher-and-handler "/" "/tmp/coleslaw/index.html")
              (hunchentoot:create-folder-dispatcher-and-handler "/" "/tmp/coleslaw/"))))

(defmethod clim:disown-frame :before (fm (self durk))
  (format *debug-io* "Cleaning up.~%")
  (when (hunchentoot:started-p (acceptor self))
    (hunchentoot:stop (acceptor self))))

(define-durk-command (com-start-acceptor)
    ((self 'hunchentoot:acceptor :gesture :select))
  (format *debug-io* "Starting acceptor.~%")
  (hunchentoot:start self))

(define-durk-command (com-stop-acceptor)
    ((self 'hunchentoot:acceptor :gesture :select))
  (format *debug-io* "Stopping acceptor.~%")
  (hunchentoot:stop self))

(clim:define-presentation-method clim:present :before ((self durk) (type durk) stream view &rest args)
  (declare (ignore args))
  (clim:formatting-item-list (stream)
    (clim:map-over-command-table-names
     (lambda (name command)
       (declare (ignore name))
       (clim:formatting-cell (stream)
         (clim:surrounding-output-with-border (stream)
          (clim:present command 'clim:command :stream stream))))
     (clim:find-command-table 'durk)))
  (terpri stream)
  (present* (acceptor self) stream)
  (terpri stream))

(clim:define-presentation-method clim:present
    ((self hunchentoot:acceptor) (type hunchentoot:acceptor) stream view &rest args)
  (declare (ignore view args))
  (clim:with-drawing-options (stream :ink (if (hunchentoot:started-p self)
                                              clim:+dark-green+
                                              clim:+dark-red+))
    (format stream "~a~%" self)))