tinmop/src/open-attach-window.lisp

;; tinmop: an humble gemini and pleroma client
;; Copyright (C) 2020  cage

;; 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 3 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, see <http://www.gnu.org/licenses/>.

(in-package :open-attach-window)

(defclass open-attach-window (focus-marked-window
                              simple-line-navigation-window
                              title-window
                              border-window)
  ((status-id
    :initform nil
    :initarg  :status-id
    :accessor status-id)))

(defun refresh-view-links-window-config (window config-window-key &key (center-position nil))
  (with-accessors ((croatoan-window     croatoan-window)
                   (selected-line-bg    selected-line-bg)
                   (selected-line-fg    selected-line-fg)
                   (unselected-line-bg  unselected-line-bg)
                   (unselected-line-fg  unselected-line-fg)) window
    (let* ((theme-style   (swconf:form-style config-window-key))
           (fg            (swconf:foreground theme-style))
           (bg            (swconf:background theme-style))
           (selected-fg   (swconf:selected-foreground theme-style))
           (selected-bg   (swconf:selected-background theme-style))
           (unselected-fg (swconf:unselected-foreground theme-style))
           (unselected-bg (swconf:unselected-background theme-style))
           (reference-window (if command-line:*gemini-full-screen-mode*
                                 *gemini-toc-window*
                                 *thread-window*))
           (win-w            (cond
                               (command-line:*gemini-full-screen-mode*
                                (- (win-width *main-window*)
                                   (win-width reference-window)))
                               (center-position
                                (truncate (/ (win-width reference-window) 2)))
                               (t
                                (win-width reference-window))))
           (win-h            (cond
                               (command-line:*gemini-full-screen-mode*
                                (swconf:config-gemini-fullscreen-links-height))
                               (center-position
                                (truncate (/ (win-height reference-window) 2)))
                               (t
                                (win-height reference-window))))
           (x                (cond
                               (command-line:*gemini-full-screen-mode*
                                (win-width reference-window))
                               (center-position
                                (truncate (- (/ (win-width *main-window*) 2)
                                             (/ win-w 2))))
                               (t
                                (win-x reference-window))))
           (y                (if center-position
                                 (truncate (- (/ (win-height *main-window*) 2)
                                              (/ win-h 2)))
                                 0)))
      (setf (c:background croatoan-window) (tui:make-win-background bg))
      (setf (c:bgcolor croatoan-window) bg)
      (setf (c:fgcolor croatoan-window) fg)
      (setf selected-line-fg selected-fg)
      (setf selected-line-bg selected-bg)
      (setf unselected-line-fg unselected-fg)
      (setf unselected-line-bg unselected-bg)
      (win-resize window win-w win-h)
      (win-move window x y)
      window)))

(defmethod refresh-config :after ((object open-attach-window))
  (refresh-view-links-window-config object swconf:+key-open-attach-window+))

(defmethod resync-rows-db ((object open-attach-window) &key
                                                         (redraw t)
                                                         (suggested-message-index nil))
  (with-accessors ((rows             rows)
                   (status-id        status-id)
                   (selected-line-bg selected-line-bg)
                   (selected-line-fg selected-line-fg)) object
    (flet ((make-rows (attach-names bg fg)
             (mapcar (lambda (name)
                         (make-instance 'line
                                        :normal-text   name
                                        :selected-text name
                                        :normal-bg     bg
                                        :normal-fg     fg
                                        :selected-bg   fg
                                        :selected-fg   bg))
                     attach-names)))
      (let ((attach-names (db:all-attachments-urls-to-status status-id
                                                             :add-reblogged-urls t)))
        (with-croatoan-window (croatoan-window object)
          (line-oriented-window:update-all-rows object
                                                (make-rows attach-names
                                                           selected-line-bg
                                                           selected-line-fg))
          (when suggested-message-index
            (select-row object suggested-message-index))
          (when redraw
            (draw object)))))))

(defun init (status-id)
  (let* ((low-level-window (make-croatoan-window :enable-function-keys t)))
    (setf *open-attach-window*
          (make-instance 'open-attach-window
                         :title             (_ "Attachments")
                         :status-id         status-id
                         :single-row-height 1
                         :uses-border-p     t
                         :keybindings       keybindings:*open-attach-keymap*
                         :croatoan-window   low-level-window))
    (refresh-config *open-attach-window*)
    (resync-rows-db *open-attach-window* :redraw nil)
    (when (not (line-oriented-window:rows-empty-p *open-attach-window*))
      (select-row *open-attach-window* 0))
    (draw *open-attach-window*)
    *open-attach-window*))

;; Note  we  can   not  use  the  function  with  the   same  name  in
;; filesystem-utils as the latter doen not check for query string
(defun get-extension (file)
  (multiple-value-bind (matchedp res)
      (cl-ppcre:scan-to-strings "(?i)[a-z0-9]\(\\.[^./?]+)(\\?.+)?$" file)
    (when matchedp
      (first-elt res))))

(defun open-attachment (url)
  (labels ((add-extension (cached-value)
             (strcat (to-s cached-value) (get-extension url)))
           (fill-cache (url)
             (let* ((cached-file-name (add-extension (db:cache-put url)))
                    (cached-output-file (os-utils:cached-file-path cached-file-name))
                    (stream (get-url-content url)))
               (fs:create-file cached-output-file :skip-if-exists t)
               (with-open-file (out-stream
                                cached-output-file
                                :element-type      '(unsigned-byte 8)
                                :if-does-not-exist :error
                                :if-exists         :supersede
                                :direction         :output)
                 (loop for byte = (read-byte stream nil nil) while byte do
                   (write-byte byte out-stream))))))
    (multiple-value-bind (program use-cache-p)
        (swconf:link-regex->program-to-use url)
      (let ((cached (db:cache-get-value url)))
        (if (not cached)
            (if (and program
                     (not use-cache-p))
                (os-utils:open-link-with-program program url)
                (progn
                  (fill-cache url)
                  (open-attachment url)))
            (let ((cached-file (os-utils:cached-file-path (add-extension cached))))
              (if (or (not (fs:file-exists-p cached-file))
                      (<= (fs:file-size cached-file) 0))
                  (progn
                    (db:cache-invalidate url)
                    (open-attachment url))
                  (os-utils:open-resource-with-external-program cached-file nil))))))))