[elpa] externals/org 0583a0c5ea: org: Add setting for remote file download policy

[ELPA Syncer]

branch: externals/org
commit 0583a0c5eaa955d4370558b980b3772bb91dd057
Author: TEC <tec@tecosaur.com>
Commit: TEC <tec@tecosaur.com>

    org: Add setting for remote file download policy
    
    * lisp/org.el (org-resource-download-policy, org-safe-remote-resources):
    Two new customisations to configure the policy for downloading remote
    resources.
    (org--should-fetch-remote-resource-p, org--safe-remote-resource-p,
    org--confirm-resource-safe): Introduce the new function
    `org--should-fetch-remote-resource-p' for internal use determining
    whether a remote resource should be downloaded according to the download
    policy.  This function makes use of two helper functions,
    `org--safe-remote-resource-p' and `org--confirm-resource-safe'.
    (org-file-contents): Apply `org--safe-remote-resource-p' to file
    downloading.
    
    * lisp/org-persist.el (org-persist-write): Apply
    `org--safe-remote-resource-p' to url downloading.
    
    * lisp/org-attach.el (org-attach-attach, org-attach-url): Apply
    `org--safe-remote-resource-p' to url downloading.
---
 lisp/org-attach.el  |  11 +++--
 lisp/org-persist.el |   5 +-
 lisp/org.el         | 130 ++++++++++++++++++++++++++++++++++++++++++++++------
 3 files changed, 127 insertions(+), 19 deletions(-)

diff --git a/lisp/org-attach.el b/lisp/org-attach.el
index b646ca76dc..c41d3df26f 100644
--- a/lisp/org-attach.el
+++ b/lisp/org-attach.el
@@ -486,7 +486,9 @@ DIR-property exists (that is different from the unset one)."
 (defun org-attach-url (url)
   "Attach URL."
   (interactive "MURL of the file to attach: \n")
-  (let ((org-attach-method 'url))
+  (let ((org-attach-method 'url)
+        (org-safe-remote-resources ; Assume saftey if in an interactive 
session.
+         (if noninteractive org-safe-remote-resources '(""))))
     (org-attach-attach url)))
 
 (defun org-attach-buffer (buffer-name)
@@ -525,9 +527,12 @@ METHOD may be `cp', `mv', `ln', `lns' or `url' default 
taken from
        ((eq method 'mv) (rename-file file attach-file))
        ((eq method 'cp) (copy-file file attach-file))
        ((eq method 'ln) (add-name-to-file file attach-file))
-       ;; We pass integer third argument to auto-expand "~" in FILE.
        ((eq method 'lns) (make-symbolic-link file attach-file 1))
-       ((eq method 'url) (url-copy-file file attach-file)))
+       ((eq method 'url)
+        (if (org--should-fetch-remote-resource-p file)
+            (url-copy-file file attach-file)
+          (error "The remote resource %S is considered unsafe, and will not be 
downloaded."
+                 file))))
       (run-hook-with-args 'org-attach-after-change-hook attach-dir)
       (org-attach-tag)
       (cond ((eq org-attach-store-link-p 'attached)
diff --git a/lisp/org-persist.el b/lisp/org-persist.el
index 0658d84018..a30c75f38e 100644
--- a/lisp/org-persist.el
+++ b/lisp/org-persist.el
@@ -657,7 +657,10 @@ COLLECTION is the plist holding data collection."
                          (format "%s-%s.%s" persist-file (md5 path) ext))))
         (unless (file-exists-p (file-name-directory file-copy))
           (make-directory (file-name-directory file-copy) t))
-        (url-copy-file path file-copy 'overwrite)
+        (if (org--should-fetch-remote-resource-p path)
+            (url-copy-file path file-copy 'overwrite)
+          (error "The remote resource %S is considered unsafe, and will not be 
downloaded."
+                 path))
         (format "%s-%s.%s" persist-file (md5 path) ext)))))
 
 (defun org-persist-write:index (container _)
diff --git a/lisp/org.el b/lisp/org.el
index 1c9eaf09a9..dd33028c66 100644
--- a/lisp/org.el
+++ b/lisp/org.el
@@ -1353,6 +1353,34 @@ For more examples, see the system specific constants
                        (string :tag "Command")
                        (function :tag "Function")))))
 
+(defcustom org-resource-download-policy 'prompt
+  "The policy applied to requests to obtain remote resources.
+
+This affects keywords like #+setupfile and #+incude on export,
+`org-persist-write:url',and `org-attach-url' in non-interactive
+Emacs sessions.
+
+This recognises four possible values:
+- t, remote resources should always be downloaded.
+- prompt, you will be prompted to download resources nt considered safe.
+- safe, only resources considered safe will be downloaded.
+- nil, never download remote resources.
+
+A resource is considered safe if it matches one of the patterns
+in `org-safe-remote-resources'."
+  :group 'org
+  :type '(choice (const :tag "Always download remote resources" t)
+                 (const :tag "Prompt before downloading an unsafe resource" 
prompt)
+                 (const :tag "Only download resources considered safe" safe)
+                 (const :tag "Never download any resources" nil)))
+
+(defcustom org-safe-remote-resources nil
+  "A list of regexp patterns matching safe URIs.
+URI regexps are applied to both URLs and Org files requesting
+remote resources."
+  :group 'org
+  :type '(list regexp))
+
 (defcustom org-open-non-existing-files nil
   "Non-nil means `org-open-file' opens non-existing files.
 
@@ -4468,21 +4496,25 @@ is available.  This option applies only if FILE is a 
URL."
     (cond
      (cache)
      (is-url
-      (with-current-buffer (url-retrieve-synchronously file)
-       (goto-char (point-min))
-       ;; Move point to after the url-retrieve header.
-       (search-forward "\n\n" nil :move)
-       ;; Search for the success code only in the url-retrieve header.
-       (if (save-excursion
-             (re-search-backward "HTTP.*\\s-+200\\s-OK" nil :noerror))
-           ;; Update the cache `org--file-cache' and return contents.
-           (puthash file
-                    (buffer-substring-no-properties (point) (point-max))
-                    org--file-cache)
-         (funcall (if noerror #'message #'user-error)
-                  "Unable to fetch file from %S"
-                  file)
-         nil)))
+      (if (org--should-fetch-remote-resource-p file)
+          (with-current-buffer (url-retrieve-synchronously file)
+            (goto-char (point-min))
+            ;; Move point to after the url-retrieve header.
+            (search-forward "\n\n" nil :move)
+            ;; Search for the success code only in the url-retrieve header.
+            (if (save-excursion
+                  (re-search-backward "HTTP.*\\s-+200\\s-OK" nil :noerror))
+                ;; Update the cache `org--file-cache' and return contents.
+                (puthash file
+                         (buffer-substring-no-properties (point) (point-max))
+                         org--file-cache)
+              (funcall (if noerror #'message #'user-error)
+                       "Unable to fetch file from %S"
+                       file)
+              nil))
+        (funcall (if noerror #'message #'user-error)
+                 "The remote resource %S is considered unsafe, and will not be 
downloaded."
+                 file)))
      (t
       (with-temp-buffer
         (condition-case nil
@@ -4495,6 +4527,74 @@ is available.  This option applies only if FILE is a 
URL."
                    file)
           nil)))))))
 
+(defun org--should-fetch-remote-resource-p (uri)
+  "Return non-nil if the URI should be fetched."
+  (or (eq org-resource-download-policy t)
+      (org--safe-remote-resource-p uri)
+      (and (eq org-resource-download-policy 'prompt)
+           (org--confirm-resource-safe uri))))
+
+(defun org--safe-remote-resource-p (uri)
+  "Return non-nil if URI is considered safe.
+This checks every pattern in `org-safe-remote-resources', and
+returns non-nil if any of them match."
+  (let ((uri-patterns org-safe-remote-resources)
+        (file-uri (and buffer-file-name
+                       (concat "file://" (file-truename buffer-file-name))))
+        match-p)
+    (while (and (not match-p) uri-patterns)
+      (setq match-p (or (string-match-p (car uri-patterns) uri)
+                        (and file-uri (string-match-p (car uri-patterns) 
file-uri)))
+            uri-patterns (cdr uri-patterns)))
+    match-p))
+
+(defun org--confirm-resource-safe (uri)
+  "Ask the user if URI should be considered safe, returning non-nil if so."
+  (unless noninteractive
+    (let ((current-file (and buffer-file-name (file-truename 
buffer-file-name)))
+          (buf (get-buffer-create "*Org Remote Resource*")))
+      ;; Set up the contents of the *Org Remote Resource* buffer.
+      (with-current-buffer buf
+        (erase-buffer)
+        (insert "An org-mode document would like to download "
+                (propertize uri 'face '(:inherit org-link :weight normal))
+                ", which is not considered safe.\n\n"
+                "Do you want to download this?  You can type\n "
+                (propertize "!" 'face 'success)
+                " to download this resource, and permanantly mark it as 
safe.\n "
+                (propertize "f" 'face 'success)
+                " to download this resource, and permanantly mark all 
resources in "
+                (propertize current-file 'face 'fixed-pitch-serif)
+                " as safe.\n "
+                (propertize "y" 'face 'warning)
+                " to download this resource, just this once.\n "
+                (propertize "n" 'face 'error)
+                " to skip this resource.\n")
+        (setq-local cursor-type nil)
+        (set-buffer-modified-p nil)
+        (goto-char (point-min)))
+      ;; Display the buffer and read a choice.
+      (save-window-excursion
+        (pop-to-buffer buf)
+        (let* ((exit-chars '(?y ?n ?! ?f ?\s))
+               (prompt (format "Please type y, n, f, or !%s: "
+                               (if (< (line-number-at-pos (point-max))
+                                      (window-body-height))
+                                   ""
+                                 ", or C-v/M-v to scroll")))
+               char)
+          (setq char (read-char-choice prompt exit-chars))
+          (when (memq char '(?! ?f))
+            (customize-push-and-save
+             'org-safe-remote-resources
+             (list (rx string-start
+                       (literal
+                        (if (and (= char ?f) current-file)
+                            (concat "file://" current-file) uri))
+                       string-end))))
+          (prog1 (memq char '(?! ?\s ?y ?f))
+            (quit-window t)))))))
+
 (defun org-extract-log-state-settings (x)
   "Extract the log state setting from a TODO keyword string.
 This will extract info from a string like \"WAIT(w@/!)\"."