Something went wrong. Try again.
A lispy web app runner with simple security (main-branch-only mirror of https://forge.ejuarezg.com/ejuarezg/tailcat-wormhole)
Something went wrong. Try again.
9.7 kB · 211 lines
at main
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212(in-package #:web-app-runner)
(defstruct password-credential "A credential read from one `pass` entry." password username)
(defparameter +credential-clipboard-timeout-seconds+ 15)(defvar *clipboard-generation* 0)(defvar *pass-availability-checked-p* nil)(defvar *pass-available-p* nil)
(cffi:defcfun ("gdk_display_get_default" %gdk-display-get-default) :pointer)(cffi:defcfun ("gdk_display_get_clipboard" %gdk-display-get-clipboard) :pointer (display :pointer))(cffi:defcfun ("gdk_clipboard_set_content" %gdk-clipboard-set-content) :int (clipboard :pointer) (provider :pointer))(cffi:defcfun ("g_bytes_new" %g-bytes-new) :pointer (data :pointer) (size :size))(cffi:defcfun ("g_bytes_unref" %g-bytes-unref) :void (bytes :pointer))(cffi:defcfun ("g_object_unref" %g-object-unref) :void (object :pointer))(cffi:defcfun ("gdk_content_provider_new_for_bytes" %gdk-content-provider-new-for-bytes) :pointer (mime-type :string) (bytes :pointer))(cffi:defcfun ("gdk_content_provider_new_union" %gdk-content-provider-new-union) :pointer (providers :pointer) (count :size))
(defun make-clipboard-bytes-provider (mime-type text) "Return an owned provider for TEXT's UTF-8 bytes, excluding the trailing NUL." (cffi:with-foreign-string ((data size) text :encoding :utf-8) (let ((bytes (%g-bytes-new data (1- size)))) (unwind-protect (%gdk-content-provider-new-for-bytes mime-type bytes) (%g-bytes-unref bytes)))))
(defun set-sensitive-clipboard-text (clipboard text) "Publish text and its no-history hint together, never as unmarked text.
Copyous and other cooperating managers recognize x-kde-passwordManagerHint.The hint is advisory; it cannot delete previously recorded history." (let ((owned-providers nil)) (unwind-protect (cffi:with-foreign-object (providers :pointer 2) (setf (cffi:mem-aref providers :pointer 0) (car (push (make-clipboard-bytes-provider "text/plain;charset=utf-8" text) owned-providers)) (cffi:mem-aref providers :pointer 1) (car (push (make-clipboard-bytes-provider "x-kde-passwordManagerHint" "secret") owned-providers))) (let ((provider (%gdk-content-provider-new-union providers 2))) ;; The union takes ownership of the child providers. (setf owned-providers nil) (unwind-protect (unless (plusp (%gdk-clipboard-set-content clipboard provider)) (error "The desktop clipboard could not accept the credential.")) (%g-object-unref provider)))) (dolist (provider owned-providers) (%g-object-unref provider)))))
(defun notify-clipboard-countdown (on-countdown remaining) "Notify the UI without allowing a stale widget to interrupt expiry." (when on-countdown (handler-case (funcall on-countdown remaining) (error () nil))))
(defun copy-credential-to-clipboard (text &key on-countdown) "Copy TEXT and clear the clipboard after 15 seconds.
ON-COUNTDOWN, when supplied, receives the remaining seconds, or -1 if GTKcannot clear the clipboard. Notification errors do not prevent expiry.Copies carry a sensitive-content hint for cooperating clipboard managers.This is a convenience timeout, not guaranteed erasure: managers that ignorethe hint may retain historical copies." (unless (and text (plusp (length text))) (error "This credential has no value to copy.")) (cffi:use-foreign-library gtk4) (let* ((display (%gdk-display-get-default)) (clipboard (if (cffi:null-pointer-p display) (cffi:null-pointer) (%gdk-display-get-clipboard display))) (remaining +credential-clipboard-timeout-seconds+)) (when (cffi:null-pointer-p clipboard) (error "The desktop clipboard is unavailable.")) (set-sensitive-clipboard-text clipboard text) (let* ((generation (incf *clipboard-generation*)) (source-id (glib:timeout-add-seconds 1 (lambda () (cond ((/= generation *clipboard-generation*) nil) ((plusp (decf remaining)) (notify-clipboard-countdown on-countdown remaining) t) (t ;; An empty string still publishes a text content provider. ;; GTK's explicit clear operation requires a NULL provider. (let ((cleared-p (plusp (%gdk-clipboard-set-content clipboard (cffi:null-pointer))))) (notify-clipboard-countdown on-countdown (if cleared-p 0 -1))) nil)))))) (notify-clipboard-countdown on-countdown remaining) source-id)))
(defun password-store-directory () "Return PASSWORD_STORE_DIR, or pass's conventional per-user default." (uiop:ensure-directory-pathname (or (uiop:getenv "PASSWORD_STORE_DIR") (merge-pathnames ".password-store/" (user-homedir-pathname)))))
(defun pass-program-path () "Return the pass command name when it is executable, otherwise NIL." (handler-case (multiple-value-bind (output error-output exit-code) (uiop:run-program '("pass" "--version") :output :string :error-output :string :ignore-error-status t) (declare (ignore output error-output)) (when (zerop exit-code) "pass")) (error () nil)))
(defun pass-available-p () "Return whether pass is available, caching the result for this process." (unless *pass-availability-checked-p* (setf *pass-available-p* (not (null (pass-program-path))) *pass-availability-checked-p* t)) *pass-available-p*)
(defun credential-entry-name-for-host (host) "Return the pass entry convention used by the runner for HOST." (format nil "web-app-runner/~A" (string-downcase host)))
(defun parse-pass-output (output) "Parse pass's first-line password and optional key/value metadata.
The first line is the password by pass convention. Metadata may contain`username`, `user`, `login`, or `email`; all other fields are ignored." (let* ((lines (uiop:split-string output :separator '(#\Newline))) (password (first lines)) (username nil)) (dolist (line (rest lines)) (let ((separator (position #\: line))) (when separator (let ((key (string-downcase (string-trim '(#\Space #\Tab) (subseq line 0 separator)))) (value (string-trim '(#\Space #\Tab) (subseq line (1+ separator))))) (when (and (null username) (member key '("username" "user" "login" "email") :test #'string=)) (setf username value)))))) (when (and password (plusp (length password))) (make-password-credential :password password :username username))))
(defun run-pass-command (arguments &key input) "Run pass without a shell and return its standard output.
The command's standard error is included in failures so a missing entry orclosed Tomb is actionable in the credentials window." (let ((pass (pass-program-path))) (unless pass (error "The pass program is not installed or is not on PATH.")) (flet ((run (input-stream) (multiple-value-bind (output error-output exit-code) (uiop:run-program (append (list "env" (format nil "PASSWORD_STORE_DIR=~A" (namestring (password-store-directory))) pass) arguments) :input input-stream :output :string :error-output :string :ignore-error-status t) (unless (zerop exit-code) (error "pass failed (exit code ~D):~%~A" exit-code (string-trim '(#\Space #\Tab #\Newline #\Return) error-output))) output))) (if input (with-input-from-string (input-stream input) (run input-stream)) (run nil)))))
(defun read-pass-credential (entry-name) "Read ENTRY-NAME from pass without invoking a shell.
The returned credential contains sensitive data and should be used briefly;the runner never stores it in global state or writes it to logs." (let ((credential (parse-pass-output (run-pass-command (list "show" "--" entry-name))))) (or credential (error "The pass entry ~A is empty." entry-name))))
(defun write-pass-credential (entry-name username password) "Store USERNAME and PASSWORD in ENTRY-NAME using pass.
The password travels through the child process's standard input, never itsargument list or environment. Existing entries are intentionally overwrittenby this explicit Save action." (when (or (null username) (zerop (length username))) (error "A username is required.")) (when (or (null password) (zerop (length password))) (error "A password is required.")) (when (or (find #\Newline username) (find #\Return username) (find #\Newline password) (find #\Return password)) (error "Username and password must be single-line values.")) (run-pass-command (list "insert" "--multiline" "--force" "--" entry-name) :input (format nil "~A~%username: ~A~%" password username)) t)