(in-package :kira)

(defclass file (node)
  ((name :accessor name :initarg :name :initform nil)
   (content-type :accessor content-type :initarg :content-type :initform nil)
   pathname
   uri
   size))

(defcollection files ((entity files-mixin))
  (cached-collection entity 'files :descending t))

;; Queue the files to be saved permanently -- so they're just dropped
;; if the request handler does not complete.
(defvar *files* '())

(defun file-pathname (file)
  (with-caching-slot (file 'pathname)
    (whereas ((id (id file)))
      (merge-pathnames
       (name file)
       (merge-pathnames
	(integer->directory id)
	+static-file-directory+)))))

(defmethod file-size ((file file))
  (with-caching-slot (file 'size)
    (let ((pathname (file-pathname file)))
      (if pathname
	  (file-size pathname)
	  0))))

(defmethod parse-parameter (name (type (eql 'file)))
  (whereas ((value (request-query-value name)))
    (when (consp value)
      (whereas ((filename (first value)))
	(let ((file
	       (make-instance-from-query
		'file
		:name (uri-encode (remove-extra-spaces filename))
		:content-type (third value))))
	  (push (cons (second value) file) *files*)
	  file)))))

(defmethod query-setf-form (place name (type (eql 'file)) default)
  (with-unique-names (file)
    `(with-query (((,name ,file) file ,default))
       (when ,file
	 (prog1 (setf ,place ,file)
	   (realize ,file))))))

(defmethod string->type (string (type (eql 'remote-file)))
  (get-file string))

(defun get-file (uri)
  (let ((uri (uri uri)))
    (multiple-value-bind (temporary-name content-type) (http-get uri)
      (when temporary-name
	(let ((file
	       (make-instance-from-query
		'file
		:external-uri uri
		:content-type content-type
		:name (let ((extensions (gethash content-type +content-type->extensions+))
			    (name (uri-name uri))
			    (type (uri-type uri)))
			(when name (setf name (uri-encode name)))
			(if (and type extensions (member type extensions :test #'string-equal))
			    name
			    (format nil "~a~@[.~a~]" (or name "0") (first extensions)))))))
	  (push (cons temporary-name file) *files*)
	  file)))))

(defun finalize-temporary-files ()
  (loop for (temporary-name . file) in *files*
	for pathname = (file-pathname file)
	when pathname do
	(ensure-directories-exist pathname)
	(lisp:system (format nil "mv ~a ~a" temporary-name pathname))
	(chmod pathname #o664)
	finally (setf *files* '())))

(defmethod render-node-title ((file file) (view null) &key)
  (let ((name (name file)))
    (if name
	(html name)
	(call-next-method))))

(defhandler ((entity files-mixin) files)
  (:title "Files")
  (:fieldset
   "Upload File"
   ((:standard-form :action (:uri-to *person* 'upload))
    (:p (file-field "file" nil))
    (:p (submit-button nil "Upload"))))
  (:collection (files entity)))

(defhandler :post ((entity files-mixin) upload)
  (with-transaction ()
    (with-query ((file file))
      (realize file)))
  (redirect entity 'files))

(defmethod render-in-style ((file file) (style (eql 'content)))
  (html
   (:h2 (render-link file :download))
   ((:ul :class "lines")
    (:li*
     "Type"
     (:princ (content-type file)))
    (:li*
     "Size"
     (scale-bytes (file-size file) *html-output*))
    (:li*
     "Uploaded by"
     (render-link (creator file)))
    (:li*
     "Uploaded on"
     (render-date (creation-time file))))))

(define-update-methods ((file file))
  (update-instance (creator file) file))

(define-update-methods instance ((entity files-mixin) (file file))
  (update-collection (files entity) file))

(defun pathname->uri (pathname)
  (make-instance
   'uri
   :path (format
	  nil
	  "/~{~a/~}~@[~a~]~@[.~a~]"
	  (let ((prefix (rest (pathname-directory +public-directory+)))
		(dir (rest (pathname-directory pathname))))
	    (whereas ((n (mismatch prefix dir :test #'string=)))
	      (unless (= n (length prefix))
		(error "~s is not in public directory ~s." pathname +public-directory+))
	      (nthcdr n dir)))
	  (pathname-name pathname)
	  (pathname-type pathname))))

(define-canonical-uri ((file file) :download)
  (:title (:princ (name file)))
  (with-caching-slot (file 'uri)
    (pathname->uri (file-pathname file))))