;; tinmop: a multiprotocol client ;; Copyright © 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 . (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 &key (ignore-cache nil)) (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) ignore-cache) (progn (db:cache-invalidate url) (open-attachment url)) (os-utils:open-resource-with-external-program cached-file nil))))))))