1069 lines
49 KiB
EmacsLisp
1069 lines
49 KiB
EmacsLisp
|
;;; trusted-files.el --- Simplistic security for Eglot and auto-complete. -*- lexical-binding: t -*-
|
||
|
;;; Commentary:
|
||
|
;;; Code:
|
||
|
(require 'cl-lib)
|
||
|
(require 'cus-edit)
|
||
|
(require 'keymap)
|
||
|
|
||
|
(eval-and-compile
|
||
|
(defconst trusted-files-generated-function-name-prefix "trusted-files--"
|
||
|
"Prefix to append to generated functions.
|
||
|
This is used by `trusted-files-add-hook-if-safe' and
|
||
|
`trusted-files-mark-function-unsafe'. Note that these two functions are
|
||
|
actually macros, so if you change this (which you probably shouldn't do), code
|
||
|
that uses these will need to be recompiled.")
|
||
|
|
||
|
(defconst trusted-files-hook-function-name-suffix
|
||
|
"@trusted-files-hook-if-safe"
|
||
|
"Suffix to append to function names in `trusted-files-add-hook-if-safe'.
|
||
|
Note that `trusted-files-add-hook-if-safe' is a macro, so if this value is
|
||
|
changed (which you probably shouldn't do), code that calls
|
||
|
`trusted-files-add-hook-if-safe' will need to be recompiled.")
|
||
|
|
||
|
(defconst trusted-files-advice-function-name-suffix
|
||
|
"@trusted-files-advice-if-safe"
|
||
|
"Suffix to append to function names in `trusted-files-mark-function-unsafe'.
|
||
|
Note that `trusted-files-mark-function-unsafe' is a macro, so if this value is
|
||
|
changed (which you probably shouldn't do), code that calls
|
||
|
`trusted-files-mark-function-unsafe' will need to be recompiled. "))
|
||
|
|
||
|
(defgroup trusted-files nil
|
||
|
"Simplistic security for Eglot, auto-complete, etc."
|
||
|
:group 'files
|
||
|
:prefix "trusted-files-")
|
||
|
|
||
|
(defcustom trusted-files-truename-trusted-directories t
|
||
|
"If non-nil, use the `file-truename' of for entries in `trusted-files-list'.
|
||
|
Note that this does not affect the current file, see
|
||
|
`trusted-files-truename-current-directory' for that."
|
||
|
:group 'trusted-files
|
||
|
:tag "Resolve Symbolic Links for Trusted Directories"
|
||
|
:type 'boolean
|
||
|
:risky t)
|
||
|
|
||
|
(defcustom trusted-files-truename-current-directory t
|
||
|
"If non-nil, use the `file-truename' of the current file when checking safety.
|
||
|
If this is nil, each link to a directory must individually be in
|
||
|
`trusted-files-list' to be considered safe. Note that this does _NOT_ effect
|
||
|
the entries in `trusted-files-list', only `default-directory'."
|
||
|
:group 'trusted-files
|
||
|
:tag "Resolve Symbolic Links for the Current Directory"
|
||
|
:type 'boolean
|
||
|
:risky t)
|
||
|
|
||
|
(defun trusted-files--remove-extra-path-parts (path)
|
||
|
"Remove extra path parts from PATH.
|
||
|
This removes \".\" and \"..\" components. The difference between this and
|
||
|
`expand-file-name' is that this will not return things like \"/..\"."
|
||
|
(let ((expanded (expand-file-name path)))
|
||
|
(while (string-prefix-p "/.." expanded)
|
||
|
(setq expanded (substring expanded 3))
|
||
|
(unless (string-prefix-p "/" expanded)
|
||
|
(setq expanded (concat "/" expanded))))
|
||
|
expanded))
|
||
|
|
||
|
(defun trusted-files--resolve-trusted-directory (path &optional leave-slash)
|
||
|
"Resolve PATH, which is resolved according to user settings.
|
||
|
If `trusted-files-truename-trusted-directories' is set, return the
|
||
|
`file-truename' of PATH. In any case, remove \".\" and \"..\" components from
|
||
|
PATH and make it absolute.
|
||
|
|
||
|
With LEAVE-SLASH, only return a path with a trialing slash if PATH has a
|
||
|
trailing slash."
|
||
|
(unless leave-slash
|
||
|
(cond
|
||
|
((file-directory-p path) (setq path (file-name-as-directory path)))
|
||
|
((file-exists-p path) (setq path (directory-file-name path)))))
|
||
|
(if trusted-files-truename-trusted-directories
|
||
|
(file-truename path)
|
||
|
(trusted-files--remove-extra-path-parts path)))
|
||
|
|
||
|
(defsubst trusted-files--resolve-current-directory (path &optional leave-slash)
|
||
|
"Resolve PATH, which is resolved according to user settings.
|
||
|
If `trusted-files-truename-current-directory' is set, return the `file-truename'
|
||
|
of PATH. In any case, remove \".\" and \"..\" components from PATH and make it
|
||
|
absolute.
|
||
|
|
||
|
With LEAVE-SLASH, only return a path with a trialing slash if PATH has a
|
||
|
trailing slash."
|
||
|
(unless leave-slash
|
||
|
(cond
|
||
|
((file-directory-p path) (setq path (file-name-as-directory path)))
|
||
|
((file-exists-p path) (setq path (directory-file-name path)))))
|
||
|
(if trusted-files-truename-current-directory
|
||
|
(file-truename path)
|
||
|
(trusted-files--remove-extra-path-parts path)))
|
||
|
|
||
|
(defun trusted-files--validate-only-allow-absolute-paths (widget)
|
||
|
"Custom validation function to only allow WIDGET to contain absolute paths."
|
||
|
(let ((path (widget-value widget)))
|
||
|
(unless (and (stringp path) (file-name-absolute-p path))
|
||
|
(widget-put widget :error "Path must be absolute")
|
||
|
widget)))
|
||
|
|
||
|
(defun trusted-files--custom-set-value (sym val)
|
||
|
"Set SYM (probably `trusted-files-list') to the alist VAL.
|
||
|
This parses the alist VAL and converts it to a hash table, resolving entries as
|
||
|
necessary."
|
||
|
(let ((table (make-hash-table :test 'equal)))
|
||
|
(dolist (entry val)
|
||
|
(cl-destructuring-bind (dir . type) entry
|
||
|
(when (file-name-absolute-p dir)
|
||
|
(let* ((resolved (trusted-files--resolve-trusted-directory dir))
|
||
|
(current (gethash resolved table)))
|
||
|
;; only add a new entry if another entry with a more specific rule
|
||
|
;; does not exist
|
||
|
(unless (eq current t)
|
||
|
(puthash resolved type table))))))
|
||
|
(set-default-toplevel-value sym table)))
|
||
|
|
||
|
(defun trusted-files--custom-get-value (sym)
|
||
|
"Convert SYM (probably `trusted-files-list') to an alist."
|
||
|
(let ((table (default-toplevel-value sym))
|
||
|
out)
|
||
|
(maphash (lambda (dir type)
|
||
|
(push (cons dir type) out))
|
||
|
table)
|
||
|
out))
|
||
|
|
||
|
(defcustom trusted-files-list ()
|
||
|
"List of directories that should be considered safe.
|
||
|
This is actually a hash table. The keys are trusted paths and the values are
|
||
|
how they are trusted. If the value is \\='subdir, that directory and all of its
|
||
|
subdirectories are trusted. Any other non-nil value mean only trust that
|
||
|
directory and its direct children. If the path is a file, either value means to
|
||
|
trust only that file.
|
||
|
|
||
|
The format of the paths is fairly specific. Thus, you probably should not
|
||
|
modify this directly. Use `trusted-files-add' and `trusted-files-remove' to add
|
||
|
a specific path. If you want to set this to some value, use `setopt' or
|
||
|
`customize-save-variable' to set it. In this case, you will need to pass an
|
||
|
alist with the cars being the directory and the cdrs being either \\='dir or
|
||
|
\\='subdir. Note that in this case, relative paths will be IGNORED. That is,
|
||
|
they will be removed before this is set. Resolve any relative paths before
|
||
|
passing them to `setopt'."
|
||
|
:group 'trusted-files
|
||
|
:tag "Trusted Directories"
|
||
|
:type '(repeat
|
||
|
(cons :tag "Entry"
|
||
|
(directory
|
||
|
:tag "Directory"
|
||
|
:validate trusted-files--validate-only-allow-absolute-paths)
|
||
|
(choice :tag "Also Trust Subdirectories"
|
||
|
(const :tag "Yes" subdir)
|
||
|
(const :tag "No" dir))))
|
||
|
:set #'trusted-files--custom-set-value
|
||
|
:get #'trusted-files--custom-get-value
|
||
|
:risky t)
|
||
|
|
||
|
(defcustom trusted-files-show-in-modeline 'dynamic-temporary-untrusted
|
||
|
"How to show the current buffer's trusted status in the mode line.
|
||
|
There are three possible values:
|
||
|
- t: always show the status
|
||
|
- \\='untrusted: show the status if `default-directory' is untrusted
|
||
|
- \\='dynamic: as above, but only if a protected function tried to run
|
||
|
- \\='dynamic-untrusted: as above, but only if the function failed
|
||
|
- \\='dynamic-temporary: save as \\='dynamic, but also show when the buffer is
|
||
|
temporarily trusted
|
||
|
- \\='dynamic-temporary-untrusted: as above, but only if a function failed
|
||
|
|
||
|
To completely disabled display of the trusted status, disable
|
||
|
`trusted-files-modeline-mode'."
|
||
|
:group 'tusted-dirs
|
||
|
:tag "Show Trusted State in Modeline"
|
||
|
:type '(choice (const :tag "Always" t)
|
||
|
(const :tag "If Untrusted" untrusted)
|
||
|
(const :tag "Dynamic" dynamic)
|
||
|
(const :tag "Dynamic if Untrusted" dynamic-untrusted)
|
||
|
(const :tag "Dynamic (or Temporary)" dynamic-temporary)
|
||
|
(const :tag "Dynamic if Untrusted (or Temporary)"
|
||
|
dynamic-temporary-untrusted))
|
||
|
:set (lambda (sym val)
|
||
|
(set-default-toplevel-value sym val)
|
||
|
(force-mode-line-update t))
|
||
|
:risky t)
|
||
|
|
||
|
(defcustom trusted-files-modeline-ignored-buffer-rules
|
||
|
'((trusted-files-normal-buffer-p . t))
|
||
|
"List of rules matching buffers in which to skip drawing the mode line.
|
||
|
Each element in this list is:
|
||
|
- a cons with the cdr being t and the car being a regexp
|
||
|
- a cons with the cdr being nil and the car being a literal buffer name
|
||
|
- a cons with a cdr of nil and the car being a function of one argument that
|
||
|
takes a buffer (not its name) and returns non-nil if that buffer should be
|
||
|
ignored.
|
||
|
- as above, but with a cdr of t. In this case, the function should return
|
||
|
non-nil if the buffer should have SHOWN. That is, the inverse of above."
|
||
|
:group 'trusted-files
|
||
|
:tag "Mode Line Ignored Buffer Rules"
|
||
|
:type '(repeat (choice (cons :tag "String Pattern"
|
||
|
(string :tag "Pattern")
|
||
|
(boolean :tag "Use Regexp"))
|
||
|
(cons :tag "Predicate Function"
|
||
|
(function :tag "Function")
|
||
|
(boolean :tag "Negated"))))
|
||
|
:risky t)
|
||
|
|
||
|
(defcustom trusted-files-always-trusted-buffer-functions
|
||
|
'(minibufferp)
|
||
|
"A list of functions that are called to test if the current buffer is safe.
|
||
|
When a buffer is tested for safety (via `trusted-files-safe-p'), this hook is
|
||
|
run. If any function returns non-nil, the current buffer is considered safe
|
||
|
without any additional checks."
|
||
|
:group 'trusted-files
|
||
|
:tag "Always Trusted Buffer Predicates"
|
||
|
:type '(repeat (function :tag "Predicate"))
|
||
|
:risky t)
|
||
|
|
||
|
(defface trusted-files-trusted-modeline-face
|
||
|
'((t))
|
||
|
"Face for the trusted notification string in the mode line."
|
||
|
:group 'trusted-files
|
||
|
:tag "Mode Line Trusted Notification Face")
|
||
|
|
||
|
(defface trusted-files-temporary-modeline-face
|
||
|
'((t . (:inherit warning)))
|
||
|
"Face for the temporarily trusted notification string in the mode line."
|
||
|
:group 'trusted-files
|
||
|
:tag "Mode Line Temporarily Trusted Notification Face")
|
||
|
|
||
|
(defface trusted-files-untrusted-modeline-face
|
||
|
'((t . (:inherit error)))
|
||
|
"Face for the untrusted notification string in the mode line."
|
||
|
:group 'trusted-files
|
||
|
:tag "Mode Line Untrusted Notification Face")
|
||
|
|
||
|
(defvar-local trusted-files--did-protected-function-run nil
|
||
|
"Non-nil if a protected function tried to run in the current buffer.")
|
||
|
;;;###autoload (put 'trusted-files--did-protected-function-run 'risky-local-variable t)
|
||
|
|
||
|
(defvar-local trusted-files--did-protected-function-fail nil
|
||
|
"Non-nil if a protected function failed to run in the current buffer.")
|
||
|
;;;###autoload (put 'trusted-files--did-protected-function-fail 'risky-local-variable t)
|
||
|
|
||
|
(defvar-local trusted-files--saved-buffer-name nil
|
||
|
"Internal variable used by `trusted-files-safe-p'.
|
||
|
This might not be accurate to the buffers current name.")
|
||
|
;;;###autoload (put 'trusted-files--saved-buffer-name 'risky-local-variable t)
|
||
|
|
||
|
(defvar trusted-files--temporarily-trusted-cache (make-hash-table :test 'equal)
|
||
|
"Hash table of temporarily trusted directories and buffers.
|
||
|
Each key is a directory or buffer. In the case of a buffer, any non-nil values
|
||
|
means that the buffer is trusted. In the case of a directory, the key is one of
|
||
|
the following:
|
||
|
- t: this directory is trusted
|
||
|
- \\='subdir: this directory and its subdirectories are trusted
|
||
|
|
||
|
Entries are removed from this list by
|
||
|
`trusted-files--cleanup-temporary-trusted-cache', which is called from
|
||
|
`kill-buffer-hook'.")
|
||
|
;;;###autoload (put 'trusted-files--temporarily-trusted-cache 'risky-local-variable t)
|
||
|
|
||
|
(defun trusted-files--hide-modeline-in-buffer-p (&optional buffer)
|
||
|
"Return non-nil if the mode line component should be hidden in BUFFER.
|
||
|
BUFFER defaults to the current buffer. For an explanation of how this is
|
||
|
decided, see `trusted-files-modeline-ignored-buffer-rules'."
|
||
|
(unless buffer (setq buffer (current-buffer)))
|
||
|
(cl-loop for entry in trusted-files-modeline-ignored-buffer-rules
|
||
|
when (pcase entry
|
||
|
(`(,(cl-type string) . nil)
|
||
|
(equal (car entry) (buffer-name buffer)))
|
||
|
(`(,(cl-type string) . t)
|
||
|
(string-match-p (car entry)
|
||
|
(buffer-name buffer)))
|
||
|
(`(,(cl-type function) . ,negate)
|
||
|
(xor (funcall (car entry) buffer) negate)))
|
||
|
return t))
|
||
|
|
||
|
(defun trusted-files--modeline-string ()
|
||
|
"Return the trusted-files mode line string for the current buffer.
|
||
|
To change when this is shown, customize `trusted-files-show-in-modeline'."
|
||
|
(let* ((safe (car (trusted-files-safe-p nil t)))
|
||
|
(temporary (car (memq safe
|
||
|
'(temp-buffer temp-dir temp-subdir)))))
|
||
|
(and (not (trusted-files--hide-modeline-in-buffer-p))
|
||
|
(or (eq trusted-files-show-in-modeline t)
|
||
|
(and temporary
|
||
|
(memq trusted-files-show-in-modeline
|
||
|
'(dynamic-temporary dynamic-temporary-untrusted)))
|
||
|
(and (not safe) (eq trusted-files-show-in-modeline 'untrusted))
|
||
|
(and trusted-files--did-protected-function-run
|
||
|
(memq trusted-files-show-in-modeline
|
||
|
'(dynamic dynamic-temporary)))
|
||
|
(and trusted-files--did-protected-function-fail
|
||
|
(memq trusted-files-show-in-modeline
|
||
|
'(dynamic-untrusted dynamic-temporary-untrusted))))
|
||
|
(list
|
||
|
(cond
|
||
|
(temporary
|
||
|
`(:propertize ,(format "Temp. Trusted %s"
|
||
|
(cl-case temporary
|
||
|
(temp-buffer "(B)")
|
||
|
(temp-dir "(D)")
|
||
|
(temp-subdir "(S)")))
|
||
|
face trusted-files-temporary-modeline-face
|
||
|
mouse-face mode-line-highlight
|
||
|
help-echo
|
||
|
,(cl-case temporary
|
||
|
(temp-buffer
|
||
|
"This buffer is temp. trusted. Click to untrust.")
|
||
|
(temp-dir
|
||
|
"This directory is temp. trusted. Click to untrust it.")
|
||
|
(temp-subdir
|
||
|
"A parent directory is temp. trusted. Click to untrust it."))
|
||
|
keymap
|
||
|
(mode-line keymap
|
||
|
(mouse-1 . trusted-files-remove-temporary-current-buffer))))
|
||
|
(safe '(:propertize "Trusted"
|
||
|
face trusted-files-trusted-modeline-face
|
||
|
help-echo
|
||
|
(cl-case safe
|
||
|
(dir "This buffer's directory (not a parent) is trusted.")
|
||
|
(subdir "A parent directory of this buffer is trusted."))))
|
||
|
(t '(:propertize "Untrusted"
|
||
|
face trusted-files-untrusted-modeline-face
|
||
|
help-echo "This buffer is untrusted.")))
|
||
|
" "))))
|
||
|
|
||
|
;;;###autoload
|
||
|
(define-minor-mode trusted-files-modeline-mode
|
||
|
"Minor mode for showing current buffer's trusted status in the mode line."
|
||
|
:group 'trusted-files
|
||
|
:global t
|
||
|
:lighter nil
|
||
|
(let ((item '(:eval (trusted-files--modeline-string))))
|
||
|
(if trusted-files-modeline-mode
|
||
|
(add-to-list 'global-mode-string item)
|
||
|
(setq global-mode-string (remove item global-mode-string))))
|
||
|
(force-mode-line-update))
|
||
|
|
||
|
;;;###autoload
|
||
|
(defun trusted-files-normal-buffer-p (&optional buffer)
|
||
|
"Return non-nil if BUFFER (or the current buffer) is a normal buffer.
|
||
|
A buffer is normal if is not hidden and it's name does not start and end with
|
||
|
asterisks."
|
||
|
(unless buffer (setq buffer (current-buffer)))
|
||
|
(and (not (string-prefix-p " " (buffer-name buffer)))
|
||
|
(not (string-match-p "\\`\\*.*\\*\\'" (buffer-name buffer)))))
|
||
|
|
||
|
(defun trusted-files--subdirectory-p (parent child &optional no-resolve)
|
||
|
"Return non-nil if CHILD is a subdirectory of PARENT.
|
||
|
This will resolve both PARENT and CHILD with
|
||
|
`trusted-files--resolve-current-directory', unless NO-RESOLVED is non-nil."
|
||
|
(unless no-resolve
|
||
|
(setq parent (trusted-files--resolve-current-directory parent)
|
||
|
child (trusted-files--resolve-current-directory child)))
|
||
|
(or (equal parent "/")
|
||
|
(equal (directory-file-name parent)
|
||
|
(directory-file-name child))
|
||
|
(and (equal parent (file-name-as-directory parent))
|
||
|
(string-prefix-p (file-name-as-directory parent) child))))
|
||
|
|
||
|
(defun trusted-files--buffer-path (&optional buffer)
|
||
|
"Return the path of BUFFER.
|
||
|
BUFFER defaults to the current buffer."
|
||
|
(unless buffer (setq buffer (current-buffer)))
|
||
|
(if-let ((file (buffer-file-name buffer)))
|
||
|
(trusted-files--resolve-current-directory file)
|
||
|
(file-name-as-directory (trusted-files--resolve-current-directory
|
||
|
(buffer-local-value 'default-directory buffer)))))
|
||
|
|
||
|
(defun trusted-files--path-and-parents (path &optional no-resolve)
|
||
|
"Return a list of PATH and each of its parent directories.
|
||
|
|
||
|
Unless NO-RESOLVE, resolve PATH with `trusted-files--resolve-current-directory'."
|
||
|
(cl-loop with start = (if no-resolve
|
||
|
path
|
||
|
(trusted-files--resolve-current-directory path))
|
||
|
for prev = nil then cur
|
||
|
for cur = start then (file-name-directory
|
||
|
(directory-file-name cur))
|
||
|
while (not (equal prev cur))
|
||
|
collect cur))
|
||
|
|
||
|
(defun trusted-files--buffer-path-and-parents (&optional buffer)
|
||
|
"Return a list of the path of BUFFER and each of its parent directories.
|
||
|
BUFFER defaults to the current buffer."
|
||
|
(trusted-files--path-and-parents (trusted-files--buffer-path buffer)))
|
||
|
|
||
|
(defsubst trusted-files--file-names-directory-p (path)
|
||
|
"Return non-nil if PATH names a directory.
|
||
|
On U*IX-like systems, this probably just checks if PATH ends with a slash."
|
||
|
(equal path (file-name-as-directory path)))
|
||
|
|
||
|
(defun trusted-files--same-file-or-direct-descendant-p
|
||
|
(parent child &optional no-resolve)
|
||
|
"Return non-nil if CHILD is a direct descendant of PARENT.
|
||
|
That is, return non-nil if PARENT and CHILD are the same path or if PARENT is a
|
||
|
directory and CHILD is a direct descendant.
|
||
|
|
||
|
Unless NO-RESOLVE is set, resolve both PARENT and CHILD with
|
||
|
`trusted-files--resolve-current-directory'."
|
||
|
(unless no-resolve
|
||
|
(setq parent (trusted-files--resolve-current-directory parent)
|
||
|
child (trusted-files--resolve-current-directory child)))
|
||
|
(or (equal parent child)
|
||
|
(and (trusted-files--file-names-directory-p parent)
|
||
|
(string-prefix-p parent child)
|
||
|
(not (cl-position ?/ (substring (directory-file-name child)
|
||
|
(length parent)))))))
|
||
|
|
||
|
(defun trusted-files--find-buffers
|
||
|
(path &optional subdir-too special-too resolved)
|
||
|
"Return a list of buffers that visit PATH or a direct descendant of PATH.
|
||
|
If SUBDIR-TOO is set, also search for subdirectories of PATH. If SPECIAL-TOO is
|
||
|
set, also consider buffers that are special. Otherwise, only consider regular,
|
||
|
visible, file-visiting buffers.
|
||
|
|
||
|
Unless RESOLVED is set, resolve PATH with
|
||
|
`trusted-files--resolve-current-directory'."
|
||
|
(unless resolved (setq path (trusted-files--resolve-current-directory path)))
|
||
|
(let (out)
|
||
|
(dolist (buffer (buffer-list) out)
|
||
|
(when (or special-too (trusted-files-normal-buffer-p buffer))
|
||
|
(let ((target-dir (trusted-files--buffer-path buffer)))
|
||
|
(when (or (and subdir-too (trusted-files--subdirectory-p
|
||
|
path target-dir))
|
||
|
(trusted-files--same-file-or-direct-descendant-p
|
||
|
path target-dir t))
|
||
|
(push buffer out)))))))
|
||
|
|
||
|
(defun trusted-files--cleanup-temporary-trusted-cache ()
|
||
|
"Cleanup `trusted-files--temporarily-trusted-cache'."
|
||
|
(remhash (current-buffer) trusted-files--temporarily-trusted-cache)
|
||
|
(cl-loop for cur in (trusted-files--buffer-path-and-parents)
|
||
|
for rule = (gethash cur trusted-files--temporarily-trusted-cache)
|
||
|
when (and rule (null (delq (current-buffer)
|
||
|
(trusted-files--find-buffers
|
||
|
cur (eq rule 'subdir)))))
|
||
|
collect cur into steps
|
||
|
and do (remhash cur trusted-files--temporarily-trusted-cache)
|
||
|
finally do
|
||
|
(when steps
|
||
|
(message "Untrusted %s" (trusted-files--pprint-list steps)))))
|
||
|
|
||
|
(add-hook 'kill-buffer-hook #'trusted-files--cleanup-temporary-trusted-cache)
|
||
|
|
||
|
(defun trusted-files--buffer-temporarily-trusted-p (buffer)
|
||
|
"Return non-nil if BUFFER is temprarily trusted.
|
||
|
This checks both BUFFER and BUFFER's `default-directory'.
|
||
|
|
||
|
Return a cons. For the car if the BUFFER is trusted, return \\='temp-buffer.
|
||
|
If `default-directory' is exactly trusted, return \\='temp-dir. If a parent
|
||
|
directory of it is trusted, return \\='temp-subdir. For the cdr, return the
|
||
|
directory that matched, or the BUFFER it itself matched."
|
||
|
(or
|
||
|
(and (gethash buffer trusted-files--temporarily-trusted-cache)
|
||
|
(cons 'temp-buffer buffer))
|
||
|
(cl-loop for cur in (trusted-files--buffer-path-and-parents buffer)
|
||
|
for i upfrom 0
|
||
|
for result = (gethash cur trusted-files--temporarily-trusted-cache)
|
||
|
;; direct parent (or exact match)
|
||
|
when (and result (< i 2)) return (cons 'temp-dir cur)
|
||
|
;; other parent
|
||
|
when (eq result 'subdir) return (cons 'temp-subdir cur))))
|
||
|
|
||
|
(defun trusted-files--permanently-trusted-p (path &optional resolved)
|
||
|
"Return non-nil if PATH is in `trusted-files-list'.
|
||
|
This will resolve PATH with `trusted-files--resolve-current-directory' unless
|
||
|
RESOLVED is non-nil.
|
||
|
|
||
|
Return a cons. For the car if PATH is trusted, return \\='file. If PATH's
|
||
|
direct parent is trusted, return \\='dir, If another parent directory of PATH is
|
||
|
trusted, return \\='subdir. For the cdr, return the directory that matched."
|
||
|
(cl-loop for cur in (trusted-files--path-and-parents path resolved)
|
||
|
for i upfrom 0
|
||
|
for result = (gethash cur trusted-files-list)
|
||
|
;; exact match
|
||
|
when (and result (zerop i)) return (cons 'file cur)
|
||
|
;; direct parent
|
||
|
when (and result (= i 1)) return (cons 'dir cur)
|
||
|
;; otherwise, other parent
|
||
|
when (eq result 'subdir) return (cons 'subdir cur)))
|
||
|
|
||
|
(defun trusted-files--always-trusted-buffer-p (buffer)
|
||
|
"Return non-nil if BUFFER is an always trusted buffer.
|
||
|
This calls each function in `trusted-files-always-trusted-buffer-functions'
|
||
|
until one of them return non-nil. If none of them does, this return nil.
|
||
|
Otherwise, it returns a cons of the symbol \\='buffer and BUFFER."
|
||
|
(when (run-hook-with-args-until-success
|
||
|
'trusted-files-always-trusted-buffer-functions buffer)
|
||
|
(cons 'buffer buffer)))
|
||
|
|
||
|
(defun trusted-files-safe-p (&optional buffer no-modify)
|
||
|
"Return non-nil if BUFFER is considered safe.
|
||
|
BUFFER defaults to the current buffer. Also, if BUFFER is unsafe, set
|
||
|
`trusted-files--did-protected-function-fail' to t unless NO-MODIFY is non-nil.
|
||
|
In any case, set `trusted-files--did-protected-function-run' to t unless
|
||
|
NO-MODIFY is non-nil.
|
||
|
|
||
|
This can return a few different things depending on how BUFFER is trusted. See
|
||
|
`trusted-files--permanently-trusted-p',
|
||
|
`trusted-files--always-trusted-buffer-p', and
|
||
|
`trusted-files--buffer-temporarily-trusted-p' for a list of possible return
|
||
|
values."
|
||
|
(unless buffer (setq buffer (current-buffer)))
|
||
|
(let ((path (trusted-files--buffer-path buffer)))
|
||
|
(unless no-modify
|
||
|
(setq trusted-files--did-protected-function-run t))
|
||
|
(let ((result (or (trusted-files--always-trusted-buffer-p buffer)
|
||
|
(trusted-files--permanently-trusted-p path)
|
||
|
(trusted-files--buffer-temporarily-trusted-p buffer))))
|
||
|
(unless (or no-modify result)
|
||
|
(setq trusted-files--did-protected-function-fail t))
|
||
|
(unless no-modify
|
||
|
(when (and trusted-files--saved-buffer-name
|
||
|
(not (equal path trusted-files--saved-buffer-name)))
|
||
|
(trusted-files--maybe-prompt-revert-newly-trusted-buffers
|
||
|
(list buffer)))
|
||
|
(setq trusted-files--saved-buffer-name path)
|
||
|
(force-mode-line-update))
|
||
|
result)))
|
||
|
|
||
|
(defun trusted-files--visible-buffer-list ()
|
||
|
"Return a list of all visible buffers.
|
||
|
A buffer is coincided visible if it's name does not start with a space."
|
||
|
(cl-delete-if (lambda (buf)
|
||
|
(string-prefix-p " " (buffer-name buf)))
|
||
|
(buffer-list)))
|
||
|
|
||
|
(defun trusted-files--pprint-buffer-name (buffer)
|
||
|
"Return a string which can represent BUFFER when prompting the user."
|
||
|
(if-let ((path (buffer-file-name buffer))
|
||
|
(file (file-name-nondirectory path)))
|
||
|
(if (equal file (buffer-name buffer))
|
||
|
file
|
||
|
(format "%s (buffer %s)" file (buffer-name buffer)))
|
||
|
(buffer-name buffer)))
|
||
|
|
||
|
(defun trusted-files-outdated-trust-information-p (&optional buffer)
|
||
|
"Return non-nil if BUFFER has outdated trust information.
|
||
|
See `trusted-files-reload-newly-trusted-buffers' for an explanation of when a
|
||
|
buffer might have outdated trust information.
|
||
|
|
||
|
If BUFFER is nil, default to the current buffer;"
|
||
|
(with-current-buffer (or buffer (current-buffer))
|
||
|
(let ((safe (trusted-files-safe-p nil t)))
|
||
|
(or (and safe trusted-files--did-protected-function-fail)
|
||
|
(and (not safe) trusted-files--did-protected-function-run
|
||
|
(not trusted-files--did-protected-function-fail))))))
|
||
|
|
||
|
(cl-defun trusted-files--outdated-buffer-list (&optional (buffers (buffer-list)))
|
||
|
"Return a list of buffers that have outdated trust information.
|
||
|
See `trusted-files-reload-newly-trusted-buffers' for an explanation of when a
|
||
|
buffer might have outdated trust information.
|
||
|
|
||
|
If BUFFERS is passed, only consider buffers in that list. Otherwise, consider
|
||
|
all live buffers (even special and hidden ones)."
|
||
|
(cl-remove-if-not #'trusted-files-outdated-trust-information-p buffers))
|
||
|
|
||
|
(defun trusted-files--princ-to-string (object)
|
||
|
"Return the output resulting from calling `princ' on OBJECT."
|
||
|
(with-output-to-string
|
||
|
(princ object standard-output)))
|
||
|
|
||
|
(defun trusted-files--pprint-list (items &optional formatter no-oxford-comma)
|
||
|
"Pretty print ITEMS, a list of things.
|
||
|
Each item will be converted to a string, using FORMATTER, before being printed.
|
||
|
If FORMATTER is nil, use `trusted-files--princ-to-string'. The FORMATTER must
|
||
|
take a single argument, the item to format, and return a string.
|
||
|
|
||
|
With NO-OXFORD-COMMA, don't insert an Oxford comma."
|
||
|
(unless formatter (setq formatter #'trusted-files--princ-to-string))
|
||
|
(let ((len (length items)))
|
||
|
(cl-case len
|
||
|
(0 "")
|
||
|
(1 (funcall formatter (car items)))
|
||
|
(2 (concat (funcall formatter (cl-first items))
|
||
|
" and "
|
||
|
(funcall formatter (cl-second items))))
|
||
|
(t (cl-loop for i upfrom 1
|
||
|
for item in items
|
||
|
when (/= len i)
|
||
|
concat (funcall formatter item)
|
||
|
and concat (if (and no-oxford-comma
|
||
|
(= i (1- len)))
|
||
|
" "
|
||
|
", ")
|
||
|
else
|
||
|
concat "and "
|
||
|
and concat (funcall formatter item))))))
|
||
|
|
||
|
;;;###autoload
|
||
|
(cl-defun trusted-files-revert-newly-trusted-buffers
|
||
|
(&optional force silent (buffers (trusted-files--visible-buffer-list)))
|
||
|
"Revert all buffers that have outdated trust information.
|
||
|
A buffer is considered to have outdated trust information if:
|
||
|
- it is marked as having a had a function fail, even though it is trusted
|
||
|
- it is marked as having had no function fail, even though it is untrusted
|
||
|
|
||
|
By default this prompts the user to save any buffers before reverting them. If
|
||
|
the user says no to saving a buffer, skip it. With FORCE, don't ask the user
|
||
|
anything and (possibly destructively) revert all buffers.
|
||
|
|
||
|
Unless SILENT is non-nil, `message' the user with a list of each revered buffer.
|
||
|
|
||
|
By default, revert all live buffers. To only check some buffers, pass a list of
|
||
|
buffers in BUFFERS."
|
||
|
(interactive)
|
||
|
(let (reverted)
|
||
|
(dolist (buffer (trusted-files--outdated-buffer-list buffers))
|
||
|
(with-current-buffer buffer
|
||
|
(if (not (buffer-file-name))
|
||
|
(when (or force
|
||
|
(and (buffer-modified-p)
|
||
|
(yes-or-no-p
|
||
|
(format "DISCARD CHANGES and revert %s?"
|
||
|
(trusted-files--pprint-buffer-name
|
||
|
buffer)))))
|
||
|
(revert-buffer nil t)
|
||
|
(push buffer reverted)))
|
||
|
(when (and (not force)
|
||
|
(buffer-modified-p)
|
||
|
(y-or-n-p (format "Save and revert %s?"
|
||
|
(trusted-files--pprint-buffer-name buffer))))
|
||
|
(save-buffer))
|
||
|
(when (or force (not (buffer-modified-p)))
|
||
|
(revert-buffer nil t)
|
||
|
(push buffer reverted))))
|
||
|
(when (and (not silent) reverted)
|
||
|
(message
|
||
|
"Reverted buffer%s %s"
|
||
|
(if (length= reverted 1) "" "s")
|
||
|
(trusted-files--pprint-list reverted
|
||
|
#'trusted-files--pprint-buffer-name)))))
|
||
|
|
||
|
(cl-defun trusted-files--maybe-prompt-revert-newly-trusted-buffers
|
||
|
(&optional (buffers (trusted-files--outdated-buffer-list
|
||
|
(trusted-files--visible-buffer-list))))
|
||
|
"If there are buffers with outdated trust, prompt the user to revert them.
|
||
|
For a definition of what qualifies as a buffer with outdated trust, see
|
||
|
`trusted-files-revert-newly-trusted-buffers'.
|
||
|
|
||
|
With BUFFERS, only consider those buffers."
|
||
|
(and buffers (y-or-n-p "Buffers with outdated trust detected! Revert?")
|
||
|
(trusted-files-revert-newly-trusted-buffers nil nil buffers)))
|
||
|
|
||
|
;;;###autoload
|
||
|
(defun trusted-files-add (path &optional no-recursive no-revert)
|
||
|
"Mark PATH as a trusted file.
|
||
|
If NO-RECURSIVE is non-nil, don't trust any subdirectories of PATH.
|
||
|
Interactively, prompt for PATH. With a prefix argument, set NO-RECURSIVE.
|
||
|
|
||
|
By default, this calls asks the user if they want to run
|
||
|
`trusted-files-revert-newly-trusted-buffers'. If NO-REVERT is set, don't ask or
|
||
|
call it.
|
||
|
|
||
|
PATH is processed according to `trusted-files-truename-trusted-directories'."
|
||
|
(interactive "fTrust File: \nP")
|
||
|
(let ((resolved (trusted-files--resolve-trusted-directory path)))
|
||
|
(puthash resolved (if no-recursive
|
||
|
t
|
||
|
'subdir)
|
||
|
trusted-files-list)
|
||
|
(customize-save-variable
|
||
|
'trusted-files-list (trusted-files--custom-get-value 'trusted-files-list))
|
||
|
;; Now that resolved is permanently trusted, we can remove it from
|
||
|
;; the temporary cache
|
||
|
(remhash resolved trusted-files--temporarily-trusted-cache)
|
||
|
(unless no-revert
|
||
|
(message "Added %s to the list of trusted directories"
|
||
|
resolved)
|
||
|
(trusted-files--maybe-prompt-revert-newly-trusted-buffers))))
|
||
|
|
||
|
;;;###autoload
|
||
|
(defun trusted-files-add-current (&optional no-recursive no-revert)
|
||
|
"Mark `default-directory' as a trusted directory.
|
||
|
NO-RECURSIVE and NO-REVERT are the same as for `trusted-files-add' (which see).
|
||
|
|
||
|
`default-directory' is processed according to
|
||
|
`trusted-files-truename-trusted-directories'."
|
||
|
(interactive "P")
|
||
|
(trusted-files-add (trusted-files--buffer-path) no-recursive no-revert))
|
||
|
|
||
|
(defun trusted-files--read-trusted-file (&optional prompt)
|
||
|
"Read a trusted directory from the minibuffer with completion.
|
||
|
PROMPT is the prompt to use, defaulting to \"Trusted File: \"."
|
||
|
(completing-read (or prompt "Trusted File: ")
|
||
|
(hash-table-keys trusted-files-list) nil t))
|
||
|
|
||
|
;;;###autoload
|
||
|
(defun trusted-files-remove (path &optional no-revert)
|
||
|
"Remove PATH from the list of trusted files.
|
||
|
Interactively, prompt for PATH.
|
||
|
|
||
|
By default, this asks the user if they want to run
|
||
|
`trusted-files-revert-newly-trusted-buffers'. If NO-REVERT is set, don't ask or
|
||
|
call it.
|
||
|
|
||
|
PATH is processed according to `trusted-files-truename-trusted-directories'."
|
||
|
(interactive (list (trusted-files--read-trusted-file "Untrust: ")))
|
||
|
(let* ((resolved (trusted-files--resolve-trusted-directory path))
|
||
|
(old-val (gethash resolved trusted-files-list)))
|
||
|
(if (not old-val)
|
||
|
(unless no-revert (message "%s is not trusted" resolved))
|
||
|
(remhash resolved trusted-files-list)
|
||
|
(customize-save-variable
|
||
|
'trusted-files-list (trusted-files--custom-get-value 'trusted-files-list))
|
||
|
(unless no-revert
|
||
|
(message "Removed %s from the list of trusted directories"
|
||
|
resolved)
|
||
|
(trusted-files--maybe-prompt-revert-newly-trusted-buffers)))))
|
||
|
|
||
|
(defun trusted-files-remove-current (&optional no-revert)
|
||
|
"Mark `default-directory' as an untrusted directory.
|
||
|
NO-REVERT is the same as for `trusted-files-remove' (which see).
|
||
|
|
||
|
`default-directory' is processed according to
|
||
|
`trusted-files-truename-trusted-directories'."
|
||
|
(interactive)
|
||
|
(trusted-files-remove (trusted-files--buffer-path) no-revert))
|
||
|
|
||
|
;;;###autoload
|
||
|
(defun trusted-files-add-temporary-directory
|
||
|
(path &optional no-recursive no-revert)
|
||
|
"Temporarily trust PATH.
|
||
|
PATH will be trusted until _ALL_ buffers that have it as their
|
||
|
`default-directory' are closed. Unless NO-RECURSIVE is set, also trust
|
||
|
subdirectories of `default-directory'. In this case buffers in all
|
||
|
subdirectories of `default-directory' will also be trusted, and PATH will not be
|
||
|
untrusted until _ALL_ of these buffers are closed as well.
|
||
|
|
||
|
Unless NO-REVERT is set, prompt the user to call
|
||
|
`trusted-files-revert-newly-trusted-buffers'.
|
||
|
|
||
|
Note that only non-special, visible buffers are considered."
|
||
|
(interactive "DTemporarily Trust: \nP")
|
||
|
(let ((resolved (trusted-files--resolve-trusted-directory path)))
|
||
|
(when (trusted-files--permanently-trusted-p resolved t)
|
||
|
(user-error "%s is already permanently trusted" resolved))
|
||
|
(unless (trusted-files--find-buffers resolved (not no-recursive) nil t)
|
||
|
(user-error "There are no buffers in %s" resolved))
|
||
|
(puthash resolved (if no-recursive t 'subdir)
|
||
|
trusted-files--temporarily-trusted-cache)
|
||
|
(unless no-revert
|
||
|
(message "Temporarily trusted %s" resolved)
|
||
|
(trusted-files--maybe-prompt-revert-newly-trusted-buffers))))
|
||
|
|
||
|
;;;###autoload
|
||
|
(defun trusted-files-add-temporary-buffer (&optional buffer-or-name no-revert)
|
||
|
"Temporarily trust BUFFER-OR-NAME, defaulting to the current buffer.
|
||
|
The buffer will be trusted until it is closed. If a new buffer visiting the
|
||
|
same file were to be created at a later time, that buffer would not be trusted.
|
||
|
Interactively, prompt for the buffer.
|
||
|
|
||
|
Unless NO-REVERT is set, prompt the user to revert the buffer if it is deemed to
|
||
|
have outdated trust information. For an explanation of what this means, see
|
||
|
`trusted-files-revert-newly-trusted-buffers'."
|
||
|
(interactive "bTemporarily Trust:")
|
||
|
(unless buffer-or-name (setq buffer-or-name (current-buffer)))
|
||
|
(unless (bufferp buffer-or-name)
|
||
|
(setq buffer-or-name (get-buffer buffer-or-name)))
|
||
|
(puthash buffer-or-name t trusted-files--temporarily-trusted-cache)
|
||
|
(unless no-revert
|
||
|
(message "Temporarily trusted %s"
|
||
|
(trusted-files--pprint-buffer-name buffer-or-name))
|
||
|
(when (trusted-files-outdated-trust-information-p buffer-or-name)
|
||
|
(trusted-files--maybe-prompt-revert-newly-trusted-buffers
|
||
|
(list buffer-or-name)))))
|
||
|
|
||
|
(defun trusted-files--filter-temporary-cache (predicate)
|
||
|
"Return anything in the temporary trust cache that matches PREDICATE.
|
||
|
PREDICATE should be a function of one argument. If will be passed each key in
|
||
|
`trusted-files--temporarily-trusted-cache'. It should return non-nil if that
|
||
|
item should be included in the returned set."
|
||
|
(cl-delete-if-not predicate
|
||
|
(hash-table-keys trusted-files--temporarily-trusted-cache)))
|
||
|
|
||
|
(defun trusted-files--read-temporary-directory (&optional prompt)
|
||
|
"Prompt for and return the path of a temporarily trusted directory.
|
||
|
PROMPT defaults to \"Temporarily Trusted Directory: \"."
|
||
|
(completing-read (or prompt "Temporarily Trusted Directory: ")
|
||
|
(trusted-files--filter-temporary-cache 'stringp)
|
||
|
nil t))
|
||
|
|
||
|
;;;###autoload
|
||
|
(defun trusted-files-remove-temporary-directory (path &optional no-revert)
|
||
|
"Untrust the temporarily trusted directory PATH.
|
||
|
|
||
|
Unless NO-REVERT is set, prompt the user to revert the buffer if it is deemed to
|
||
|
have outdated trust information. For an explanation of what this means, see
|
||
|
`trusted-files-revert-newly-trusted-buffers'."
|
||
|
(interactive (list (trusted-files--read-temporary-directory
|
||
|
"Untrust Directory: ")))
|
||
|
(let ((resolved (trusted-files--resolve-trusted-directory path)))
|
||
|
(remhash resolved trusted-files--temporarily-trusted-cache)
|
||
|
(unless no-revert
|
||
|
(message "Untrusted %s" resolved)
|
||
|
(trusted-files--maybe-prompt-revert-newly-trusted-buffers))))
|
||
|
|
||
|
(defun trusted-files--read-temporary-buffer (&optional prompt)
|
||
|
"Prompt the user for a temporarily trusted buffer and it (not its name).
|
||
|
PROMPT defaults to \"Temporarily Trusted Buffer: \"."
|
||
|
(let ((names (mapcar 'buffer-name
|
||
|
(trusted-files--filter-temporary-cache 'bufferp))))
|
||
|
(get-buffer (read-buffer (or prompt "Temporarily Trusted Buffer: ")
|
||
|
nil t (lambda (buf-name)
|
||
|
(unless (stringp buf-name)
|
||
|
(setq buf-name (car buf-name)))
|
||
|
(member buf-name names))))))
|
||
|
|
||
|
;;;###autoload
|
||
|
(defun trusted-files-remove-temporary-buffer (&optional buffer-or-name no-revert)
|
||
|
"Untust BUFFER-OR-NAME if it is a temporarily trusted buffer.
|
||
|
If it was trusted, return non-nil, otherwise, return nil. Note that this only
|
||
|
untrusts BUFFER-OR-NAME, and not its `default-directory'. For that, see
|
||
|
`trusted-files-remove-temporary-directory'.
|
||
|
|
||
|
Unless NO-REVERT is set, prompt the user to revert the buffer if it is deemed to
|
||
|
have outdated trust information. For an explanation of what this means, see
|
||
|
`trusted-files-revert-newly-trusted-buffers'."
|
||
|
(interactive (list (trusted-files--read-temporary-buffer "Untrust Buffer: ")))
|
||
|
(unless buffer-or-name (setq buffer-or-name (current-buffer)))
|
||
|
(unless (bufferp buffer-or-name)
|
||
|
(setq buffer-or-name (get-buffer buffer-or-name)))
|
||
|
(remhash buffer-or-name trusted-files--temporarily-trusted-cache)
|
||
|
(unless no-revert
|
||
|
(message "Untrusted %s"
|
||
|
(trusted-files--pprint-buffer-name buffer-or-name))
|
||
|
(when (trusted-files-outdated-trust-information-p buffer-or-name)
|
||
|
(trusted-files--maybe-prompt-revert-newly-trusted-buffers
|
||
|
(list buffer-or-name)))))
|
||
|
|
||
|
;;;###autoload
|
||
|
(defun trusted-files-remove-temporary-current-buffer (&optional no-revert)
|
||
|
"Untrust the current buffer, however it's temporarily trusted.
|
||
|
This will either untrust the current buffer directly, untrust its
|
||
|
`default-directory', or untrust a parent of its `default-directory'. If need
|
||
|
be, it may do multiple of these.
|
||
|
|
||
|
Unless NO-REVERT is set, prompt the user to revert the buffer if it is deemed to
|
||
|
have outdated trust information. For an explanation of what this means, see
|
||
|
`trusted-files-revert-newly-trusted-buffers'."
|
||
|
(interactive)
|
||
|
(let (steps)
|
||
|
(while-let ((how (cdr (trusted-files--buffer-temporarily-trusted-p
|
||
|
(current-buffer)))))
|
||
|
(push how steps)
|
||
|
(if (stringp how)
|
||
|
(trusted-files-remove-temporary-directory how t)
|
||
|
(trusted-files-remove-temporary-buffer how t)))
|
||
|
(unless no-revert
|
||
|
(message "Untrusted %s"
|
||
|
(trusted-files--pprint-list
|
||
|
(nreverse steps)
|
||
|
(lambda (elt)
|
||
|
(if (stringp elt)
|
||
|
elt
|
||
|
(concat "buffer " (buffer-name elt))))))
|
||
|
(trusted-files--maybe-prompt-revert-newly-trusted-buffers))))
|
||
|
|
||
|
(eval-and-compile
|
||
|
(defun trusted-files--quoted-symbol-p (form)
|
||
|
"Return non-nil if FORM is a quoted symbol.
|
||
|
This returns non-nil if FORM is a proper list of two elements, the first being
|
||
|
the symbol \\='quote or \\='function and the second being a symbol."
|
||
|
(and (memq (car-safe form) '(function quote))
|
||
|
(consp (cdr form))
|
||
|
(symbolp (cadr form))
|
||
|
(null (cddr form)))))
|
||
|
|
||
|
(defmacro trusted-files-only-if-safe (function &optional replacement prefix suffix)
|
||
|
"Return a function that will call FUNCTION if `default-directory' is safe.
|
||
|
If REPLACEMENT is non-nil, call it instead of FUNCTION if `default-directory' is
|
||
|
unsafe. REPLACEMENT is called with the same arguments that FUNCTION would have
|
||
|
been called with.
|
||
|
|
||
|
If either PREFIX or SUFFIX is a string and FUNCTION is a symbol (this is a
|
||
|
macro, so these must be true at compile time), define a new function named by
|
||
|
concatenating PREFIX, the name of FUNCTION, and SUFFIX."
|
||
|
(let* ((args (make-symbol "args"))
|
||
|
(evaled-prefix (eval prefix t))
|
||
|
(evaled-suffix (eval suffix t))
|
||
|
(do-defun (and (or (stringp evaled-prefix) (stringp evaled-suffix))
|
||
|
(trusted-files--quoted-symbol-p function))))
|
||
|
`(,@(if do-defun
|
||
|
(list 'defun (intern (concat (when (stringp evaled-prefix)
|
||
|
evaled-prefix)
|
||
|
(symbol-name (cl-second function))
|
||
|
(when (stringp evaled-suffix)
|
||
|
evaled-suffix))))
|
||
|
'(lambda))
|
||
|
(&rest ,args)
|
||
|
,@(when do-defun
|
||
|
(list (format "Execute `%s' when `default-directory' is safe.
|
||
|
The safety check is done with `trusted-files-safe-p'."
|
||
|
(cl-second function))))
|
||
|
(require 'trusted-files)
|
||
|
(if (trusted-files-safe-p)
|
||
|
(apply ,function ,args)
|
||
|
,@(when replacement
|
||
|
(list `(apply ,replacement ,args)))))))
|
||
|
|
||
|
(cl-defmacro trusted-files-add-hook-if-safe
|
||
|
(hook function &optional (depth nil depthp) (local nil localp))
|
||
|
"Like `add-hook', but only when `default-directory' is trusted.
|
||
|
This will add FUNCTION to HOOK, initializing it if necessary. DEPTH and LOCAL
|
||
|
are the same as `add-hook' (which see). If FUNCTION is a symbol, it is wrapped
|
||
|
in a new function who's name is formed by concatenating the name of FUNCTION and
|
||
|
`trusted-files-hook-function-name-suffix'."
|
||
|
`(add-hook ,hook (trusted-files-only-if-safe
|
||
|
,function nil ,trusted-files-generated-function-name-prefix
|
||
|
,trusted-files-hook-function-name-suffix)
|
||
|
,@(when depthp
|
||
|
(list depth))
|
||
|
,@(when localp
|
||
|
(list local))))
|
||
|
|
||
|
(defun trusted-files-remove-hook (hook function &optional local)
|
||
|
"Remove FUNCTION from HOOK if it was added by trusted-files.
|
||
|
This undoes `trusted-files-add-hook-if-safe'. LOCAL is the same for this as for
|
||
|
`add-hook'. This only works if FUNCTION is a symbol."
|
||
|
(cl-check-type function symbol)
|
||
|
(when-let ((wrapped (intern-soft
|
||
|
(format "%s%s%s"
|
||
|
trusted-files-generated-function-name-prefix
|
||
|
(symbol-name function)
|
||
|
trusted-files-hook-function-name-suffix))))
|
||
|
(remove-hook hook wrapped local)))
|
||
|
|
||
|
(eval-and-compile
|
||
|
(defun trusted-files--format-doc-string (format &rest args)
|
||
|
"Call `format' fill the output as a documentation string.
|
||
|
This will call `format' using FORMAT and ARGS. Every paragraph in the output
|
||
|
except the first line will then be filled to a `fill-column' of 80 using
|
||
|
`fill-region'."
|
||
|
(let ((raw-string (apply 'format format args)))
|
||
|
(with-temp-buffer
|
||
|
(insert raw-string)
|
||
|
(goto-char (point-min))
|
||
|
(forward-line)
|
||
|
(fill-individual-paragraphs (point) (point-max))
|
||
|
(buffer-string))))
|
||
|
|
||
|
(defun trusted-files--make-advice-function (target replacement)
|
||
|
"Make `:around' advice for TARGET to only call it in safe directories.
|
||
|
If REPLACEMENT is non-nil, it will be called instead in unsafe directories."
|
||
|
(let ((oldfun (make-symbol "oldfun"))
|
||
|
(args (make-symbol "args"))
|
||
|
(do-defun (trusted-files--quoted-symbol-p target)))
|
||
|
`(,@(if do-defun
|
||
|
`(defun ,(intern
|
||
|
(concat trusted-files-generated-function-name-prefix
|
||
|
(symbol-name (cl-second target))
|
||
|
trusted-files-advice-function-name-suffix)))
|
||
|
'(lambda))
|
||
|
(,oldfun &rest ,args)
|
||
|
,@(when do-defun
|
||
|
(list
|
||
|
(trusted-files--format-doc-string
|
||
|
"Only call `%s' in safe directories.
|
||
|
This is meant to be used as `:around' advice. The safety check is done with
|
||
|
`trusted-files-safe-p'. If this check fails, %s."
|
||
|
(symbol-name (cl-second target))
|
||
|
(cond
|
||
|
((trusted-files--quoted-symbol-p replacement)
|
||
|
(concat (symbol-name (cl-second replacement))
|
||
|
" is called instead"))
|
||
|
(replacement
|
||
|
"an anonymous function is called instead.")
|
||
|
(t "nil is returned instead.")))))
|
||
|
(require 'trusted-files)
|
||
|
(if (trusted-files-safe-p)
|
||
|
(apply ,oldfun ,args)
|
||
|
,@(when replacement
|
||
|
(list `(apply ,replacement ,args))))))))
|
||
|
|
||
|
(defmacro trusted-files-mark-function-unsafe (function &optional replacement)
|
||
|
"Mark FUNCTION as only being runnable in safe directories.
|
||
|
This will add advice to FUNCTION such that it will simply return nil unless the
|
||
|
current directory is safe. If REPLACEMENT is non-nil, it will be run instead of
|
||
|
FUNCTION in unsafe directories. If FUNCTION is a symbol, it is wrapped
|
||
|
in a new function who's name is formed by concatenating the name of FUNCTION and
|
||
|
`trusted-files-advice-function-name-suffix'.
|
||
|
|
||
|
This will attempt to make the advice run before any other advice by giving it a
|
||
|
depth of -100 (see `add-function' for what this means), however, there is
|
||
|
nothing stopping other functions from doing this as well, so care must be taken
|
||
|
that these other pieces of advice do not call potentially unsafe functions."
|
||
|
(let ((advice (trusted-files--make-advice-function function replacement)))
|
||
|
(if (trusted-files--quoted-symbol-p function)
|
||
|
`(advice-add ,function :around ,advice '(:depth -100))
|
||
|
`(add-function :around ,function ,advice '(:depth -100)))))
|
||
|
|
||
|
(defun trusted-files-unmark-function (function)
|
||
|
"Mark FUNCTION as safe for execution in unsafe directories.
|
||
|
This undoes the effects of `trusted-files-mark-function-unsafe'. This only
|
||
|
works if FUNCTION is a symbol.
|
||
|
|
||
|
Note that this is a function and that is a macro. Thus, this will only work if
|
||
|
the values of `trusted-files-generated-function-name-prefix' and
|
||
|
`trusted-files-advice-function-name-suffix' are the same as when
|
||
|
`trusted-files-mark-function-unsafe' was compiled."
|
||
|
(cl-check-type function symbol)
|
||
|
(when-let ((advice (intern-soft
|
||
|
(format "%s%s%s"
|
||
|
trusted-files-generated-function-name-prefix
|
||
|
(symbol-name function)
|
||
|
trusted-files-advice-function-name-suffix))))
|
||
|
(advice-remove function advice)))
|
||
|
|
||
|
;;; Wrapper functions
|
||
|
(defmacro trusted-files--define-safe-wrapper (function &optional require)
|
||
|
"Define a safe wrapper around FUNCTION.
|
||
|
FUNCTION must be an unquoted symbol (checked at compile time). A new function
|
||
|
will be defined by prefixing FUNCTION's name with \"trusted-files-\" and
|
||
|
suffixing it with \"-if-safe\". If FUNCTION is a command, it will be executed
|
||
|
with `command-execlute'. Otherwilse, will be called with `funcall' and passed no
|
||
|
arguments.
|
||
|
|
||
|
If REQUIRE is non-nil, it should be a symbol that will be passed to `require' if
|
||
|
it is deemed safe to run FUNCTION."
|
||
|
(cl-check-type function symbol)
|
||
|
(let ((args (make-symbol "args"))
|
||
|
(interactive (make-symbol "interactive")))
|
||
|
`(defun ,(intern (concat "trusted-files-" (symbol-name function) "-if-safe"))
|
||
|
(&rest ,args)
|
||
|
,(format "Call `%s' only if it is safe to do so.
|
||
|
The check if performed with `trusted-files-safe-p'.%s"
|
||
|
function (if (stringp (help-function-arglist nil))
|
||
|
""
|
||
|
(format "\n\n%s" (cons 'fn (help-function-arglist
|
||
|
function t)))))
|
||
|
(declare (interactive-only ,(format "use `%s' directly instead"
|
||
|
function)))
|
||
|
,@(when (commandp function)
|
||
|
(list `(interactive nil ,@(command-modes function))))
|
||
|
;; this comes first to make sure that it is never showed by a macro
|
||
|
;; wrapping it in `lambda'.
|
||
|
(let ((,interactive (called-interactively-p 'any)))
|
||
|
(require 'trusted-files)
|
||
|
(when (trusted-files-safe-p)
|
||
|
,@(when require
|
||
|
(list `(require ',require)))
|
||
|
(if ,interactive
|
||
|
(call-interactively #',function)
|
||
|
(apply #',function ,args)))))))
|
||
|
|
||
|
(trusted-files--define-safe-wrapper eglot eglot)
|
||
|
(trusted-files--define-safe-wrapper eglot-ensure eglot)
|
||
|
(trusted-files--define-safe-wrapper flymake-mode flymake)
|
||
|
(trusted-files--define-safe-wrapper flycheck-mode flycheck)
|
||
|
(trusted-files-mark-function-unsafe #'elisp-completion-at-point)
|
||
|
|
||
|
;;;###autoload
|
||
|
(defvar-keymap trusted-files-map
|
||
|
:name "Trusted Files"
|
||
|
:doc "Prefix keymap for working with trusted files."
|
||
|
"a" #'trusted-files-add
|
||
|
"A" #'trusted-files-add-current
|
||
|
"r" #'trusted-files-remove
|
||
|
"R" #'trusted-files-remove-current
|
||
|
"b" #'trusted-files-add-temporary-buffer
|
||
|
"B" #'trusted-files-remove-temporary-buffer
|
||
|
"d" #'trusted-files-add-temporary-directory
|
||
|
"D" #'trusted-files-remove-temporary-directory)
|
||
|
|
||
|
(provide 'trusted-files)
|
||
|
;;; trusted-files.el ends here
|