(in-package :kira)

(defvar *thumbnail-width* 100)
(defvar *thumbnail-height* 200)

(defelement :image-uri (image &rest args)
  (rebinding (image)
    `(typecase ,image
       ((or string uri) (*ml ,image))
       (file (*ml (:uri-to ,image ,@args))))))

(defun render-thumbnail (image &key (width *thumbnail-width*) (height *thumbnail-height*))
  (when image (html ((:img :src (:image-uri image :thumbnail :width width :height height) :alt "")))))

(defun render-thumbnail-with-link (image &rest args)
  (when image
    (html
     ((:a :title "link to original image")
      (:image-uri image :download)
      (apply #'render-thumbnail image args)))))

(defmacro attribute-output (&body forms)
  `(escape (let ((*allow-elements-p* nil))
	     (html-output ,@forms))
           "\""))

(defun render-image (node &key (default (default-image *root*)) (width *thumbnail-width*) (height *thumbnail-height*))
  (whereas ((image (or (image node) default)))
    (if (viewing node)
	(render-thumbnail-with-link image :width width :height height)
	(html
	 ((:a :title (attribute-output (render-title node)))
	  (:uri-to node)
	  (render-thumbnail image :width width :height height))))))

(defun render-avatar (node &key (default (default-image *root*)) (width 190) (height nil))
  (whereas ((image (or (image node) default)))
    (html
     ((:p :class "avatar")
      (render-image node :width width :height height)))))

(define-canonical-uri ((image node) :thumbnail &key (width *thumbnail-width*) (height *thumbnail-height*))
  (unless (typep image 'file) (setf image (image image)))
  (when width (assert (< 10 width 1000)))
  (when height (assert (< 10 height 1000)))
  (let* ((geometry (format nil "~@[~d~]~@[x~d~]" width height))
	 (name (format nil "~a-~a" geometry (name image)))
	 (original-pathname (file-pathname image))
	 (thumb-pathname (merge-pathnames name original-pathname)))
    (prog1 (pathname->uri thumb-pathname)
      (unless (plusp (file-size thumb-pathname))
	(lisp:system (format nil "convert -thumbnail '~a>' ~a ~a" geometry original-pathname thumb-pathname))
	(chmod thumb-pathname #o664)))))