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.
47 kB · 1012 lines
at main
12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013(in-package #:web-app-runner)
(defparameter +application-id+ "com.ejuarezg.web-app-runner")(defparameter +inactivity-timeout-seconds+ (* 5 60))(defparameter +usage+ "Usage: web-app-runner [URL ...]
Open each URL in its own minimal WebKitGTK window. A URL without a schemeuses HTTPS. With no URL, the app prompts for a website.
Options: -h, --help Show this help text.
Privacy and credentials: Ctrl+Shift+L Lock the runner. Ctrl+Shift+P Open credentials for the active browser window (when pass is installed). Keep unlocked Inhibit automatic locking for the current website window. Ctrl+L Focus and select the active address field. The runner locks automatically after five minutes without input.")
(defun normalize-url (url) "Return URL with an HTTPS scheme, or signal an error for unsupported schemes." (let ((trimmed (string-trim '(#\Space #\Tab #\Newline #\Return) url))) (when (zerop (length trimmed)) (error "A URL cannot be empty.")) (cond ((or (uiop:string-prefix-p "https://" trimmed) (uiop:string-prefix-p "http://" trimmed)) trimmed) ((search "://" trimmed) (error "Only HTTP and HTTPS URLs are supported: ~A" url)) (t (format nil "https://~A" trimmed)))))
(defun parse-command-line (arguments) "Parse ARGUMENTS and return either :HELP or a list of normalized URLs." (cond ((some (lambda (argument) (member argument '("-h" "--help") :test #'string=)) arguments) :help) (t (mapcar #'normalize-url arguments))))
(defun xdg-directory (variable fallback) (uiop:ensure-directory-pathname (or (uiop:getenv variable) fallback)))
(defvar *profile-key* nil);; Test-only bindings let profile lifecycle tests use temporary XDG roots.(defvar *runner-data-directory-override* nil)(defvar *runner-cache-directory-override* nil)
(cffi:define-foreign-library libc (:unix "libc.so.6") (t (:default "libc")))(cffi:defcfun ("chmod" %chmod) :int (path :string) (mode :uint))
(defun ensure-private-directory (directory) "Create DIRECTORY and restrict it to the current account (0700)." (ensure-directories-exist directory) (cffi:use-foreign-library libc) (unless (zerop (%chmod (namestring directory) #o700)) (error "Could not restrict access to ~A." directory)) directory)
(defun restrict-file-to-owner (file) "Restrict FILE to the current account (0600)." (cffi:use-foreign-library libc) (unless (zerop (%chmod (namestring file) #o600)) (error "Could not restrict access to ~A." file)) file)
(defun runner-data-directory () "Return the XDG state directory shared only by runner configuration." (or *runner-data-directory-override* (merge-pathnames "web-app-runner/" (xdg-directory "XDG_DATA_HOME" (merge-pathnames ".local/share/" (user-homedir-pathname))))))
(defun runner-cache-directory () "Return the XDG cache root used only by this runner." (or *runner-cache-directory-override* (merge-pathnames "web-app-runner/" (xdg-directory "XDG_CACHE_HOME" (merge-pathnames ".cache/" (user-homedir-pathname))))))
(defun url-host (url) "Return URL's hostname, excluding user information and a port number." (let* ((start (+ 3 (search "://" url))) (end (or (position-if (lambda (character) (member character '(#\/ #\? #\#))) url :start start) (length url))) (authority (subseq url start end)) (host-and-port (subseq authority (1+ (or (position #\@ authority :from-end t) -1))))) (string-downcase (cond ((and (plusp (length host-and-port)) (char= (char host-and-port 0) #\[)) ;; IPv6 literals contain colons, so retain only their bracketed host. (let ((closing-bracket (position #\] host-and-port))) (if closing-bracket (subseq host-and-port 1 closing-bracket) host-and-port))) (t (subseq host-and-port 0 (or (position #\: host-and-port) (length host-and-port))))))))
(defun profile-key-for-urls (urls) "Return a filesystem-safe, stable key for the URLs opened in one runner." (let ((hosts (sort (remove-duplicates (mapcar #'url-host urls) :test #'string=) #'string<))) (map 'string (lambda (character) (if (or (alphanumericp character) (char= character #\.)) (char-downcase character) #\-)) (format nil "~{~A~^-~}" hosts))))
(defun runner-profiles-data-directory () (merge-pathnames "profiles/" (runner-data-directory)))
(defun runner-profiles-cache-directory () (merge-pathnames "profiles/" (runner-cache-directory)))
(defun profile-data-directory () "Return the data directory for the current runner target profile." (merge-pathnames (format nil "~A/" *profile-key*) (runner-profiles-data-directory)))
(defun profile-cache-directory () "Return the cache directory for the current runner target profile." (merge-pathnames (format nil "~A/" *profile-key*) (runner-profiles-cache-directory)))
(defun saved-runner-urls () "Return URLs for profiles that have previously been opened by the runner." (let ((profiles-directory (runner-profiles-data-directory))) (when (probe-file profiles-directory) (sort (loop for profile-directory in (directory (merge-pathnames "*/" profiles-directory)) for profile-key = (car (last (pathname-directory profile-directory))) when (and (stringp profile-key) (plusp (length profile-key)) (every (lambda (character) (or (alphanumericp character) (member character '(#\. #\-)))) profile-key) (probe-file (merge-pathnames "webkit/" profile-directory))) collect (format nil "https://~A" profile-key)) #'string<))))
(defun webkit-data-directory () (merge-pathnames "webkit/" (profile-data-directory)))
(defun webkit-cache-directory () (merge-pathnames "webkit/" (profile-cache-directory)))
(defun make-persistent-network-session () "Create a persistent session isolated from all other WebKitGTK applications." (ensure-webkitgtk-libraries-loaded) (let ((data-directory (webkit-data-directory)) (cache-directory (webkit-cache-directory))) (dolist (directory (list (runner-data-directory) (runner-profiles-data-directory) (profile-data-directory) data-directory (runner-cache-directory) (runner-profiles-cache-directory) (profile-cache-directory) cache-directory)) (ensure-private-directory directory)) (let ((session (webkit:make-network-session :data-directory (namestring data-directory) :cache-directory (namestring cache-directory)))) (setf (webkit:cookie-manager-persistent-storage (webkit:network-session-cookie-manager session)) (list (namestring (merge-pathnames "cookies.sqlite" (profile-data-directory))) webkit:+cookie-persistent-storage-sqlite+)) session)))
(defparameter +pin-iterations+ 600000)(defvar *forget-cookies-on-close-p* nil)(defvar *forget-cookie-checkboxes* nil)(defvar *syncing-cookie-checkboxes-p* nil)(defvar *network-session* nil)(defvar *web-views* nil)(defvar *website-data-clear-completion* nil)(defvar *interface-color-scheme-settings* nil)(defvar *gtk-settings* nil)(defvar *runner-locked-p* nil)(defvar *runner-locks* nil)(defvar *browser-addresses* nil)(defvar *credential-windows* nil)(defvar *active-browser-window* nil)(defvar *active-browser-web-view* nil)(defvar *last-user-activity-time* 0)(defvar *inactivity-source-id* nil)(defvar *lock-css-provider* nil)
(defstruct browser-lock window overlay pin-entry status submit web-view controls inhibit-auto-lock-p)
(cffi:define-foreign-library webkitgtk (:unix "libwebkitgtk-6.0.so.4") (t (:default "libwebkitgtk-6.0")))(cffi:define-foreign-library gobject (:unix "libgobject-2.0.so.0") (t (:default "libgobject-2.0")))(cffi:define-foreign-library gtk4 (:unix "libgtk-4.so.1") (t (:default "libgtk-4")));; Loading WebKitGTK while producing an SBCL image can start foreign threads;;; SBCL cannot safely save an image in that state. Load these libraries only;; when the browser session is first needed, after the executable has started.(defun ensure-gobject-library-loaded () (cffi:use-foreign-library gobject))
(defun ensure-webkitgtk-libraries-loaded () (cffi:use-foreign-library webkitgtk) (ensure-gobject-library-loaded))
(cffi:defcstruct g-value (g-type :size) (data :pointer :count 2))
(cffi:defcfun ("webkit_web_view_get_type" %webkit-web-view-get-type) :size)(cffi:defcfun ("webkit_network_session_get_type" %webkit-network-session-get-type) :size)(cffi:defcfun ("g_object_new_with_properties" %g-object-new-with-properties) :pointer (object-type :size) (property-count :uint) (property-names :pointer) (values :pointer))(cffi:defcfun ("g_value_init" %g-value-init) :pointer (value :pointer) (g-type :size))(cffi:defcfun ("g_value_set_object" %g-value-set-object) :void (value :pointer) (object :pointer))(cffi:defcfun ("g_value_set_boolean" %g-value-set-boolean) :void (value :pointer) (boolean :int))(cffi:defcfun ("g_value_unset" %g-value-unset) :void (value :pointer))(cffi:defcfun ("g_type_from_name" %g-type-from-name) :size (name :string))(cffi:defcfun ("g_object_set_property" %g-object-set-property) :void (object :pointer) (property-name :string) (value :pointer))(cffi:defcfun ("gtk_application_set_accels_for_action" %gtk-application-set-accels-for-action) :void (application :pointer) (detailed-action-name :string) (accelerators :pointer))
(cffi:defcfun ("webkit_website_data_manager_clear" %webkit-website-data-manager-clear) :void (manager :pointer) (types :uint) (timespan :int64) (cancellable :pointer) (callback :pointer) (user-data :pointer))(cffi:defcfun ("webkit_website_data_manager_clear_finish" %webkit-website-data-manager-clear-finish) :int (manager :pointer) (result :pointer) (error :pointer))(cffi:defcfun ("g_error_free" %g-error-free) :void (error :pointer))
(cffi:defcallback website-data-cleared :void ((source :pointer) (result :pointer) (user-data :pointer)) (declare (ignore user-data)) (cffi:with-foreign-object (error :pointer) (setf (cffi:mem-ref error :pointer) (cffi:null-pointer)) (let ((successp (not (zerop (%webkit-website-data-manager-clear-finish source result error))))) (unless successp (format *error-output* "Unable to clear runner data on close.~%")) (let ((error-pointer (cffi:mem-ref error :pointer))) (unless (cffi:null-pointer-p error-pointer) (%g-error-free error-pointer))) (when successp (delete-persistent-cookies)) (when *website-data-clear-completion* (let ((completion *website-data-clear-completion*)) (setf *website-data-clear-completion* nil) (funcall completion successp))))))
(defun set-gtk-prefer-dark-theme (settings darkp) "Set GTK's theme variant using its deprecated-but-supported GTK4 setting." (ensure-gobject-library-loaded) (cffi:with-foreign-object (value '(:struct g-value)) (cffi:foreign-funcall "memset" :pointer value :int 0 :size (cffi:foreign-type-size '(:struct g-value)) :pointer) (unwind-protect (progn (%g-value-init value (%g-type-from-name "gboolean")) (%g-value-set-boolean value (if darkp 1 0)) (%g-object-set-property (gir-wrapper:object-pointer settings) "gtk-application-prefer-dark-theme" value)) (%g-value-unset value))))
(defun follow-system-color-scheme (widget) "Make GTK title bars follow GNOME's light/dark preference as it changes." (unless *interface-color-scheme-settings* (let ((gtk-settings (widget-settings widget)) (interface-settings (gio:make-settings :schema-id "org.gnome.desktop.interface"))) (setf *gtk-settings* gtk-settings *interface-color-scheme-settings* interface-settings) (labels ((sync-theme () (set-gtk-prefer-dark-theme gtk-settings (string= (gio:settings-get-string interface-settings "color-scheme") "prefer-dark")))) (sync-theme) (connect interface-settings "changed::color-scheme" (lambda (settings key) (declare (ignore settings key)) (sync-theme)))))))
(defun note-user-activity (&optional window web-view) "Record activity and, for browser input, remember the active browser session." (setf *last-user-activity-time* (get-internal-real-time)) (when (and window web-view) (setf *active-browser-window* window *active-browser-web-view* web-view)))
(defun inactivity-seconds () (/ (- (get-internal-real-time) *last-user-activity-time*) (float internal-time-units-per-second)))
(defun active-browser-inhibits-auto-lock-p () "Return true when the active browser window opts out of inactivity locking." (let ((lock (find *active-browser-web-view* *runner-locks* :key #'browser-lock-web-view :test #'eq))) (and lock (browser-lock-inhibit-auto-lock-p lock))))
(defun start-inactivity-monitor () (note-user-activity) (setf *inactivity-source-id* (glib:timeout-add-seconds 1 (lambda () (when (and (not *runner-locked-p*) (plusp (length *web-views*)) (not (active-browser-inhibits-auto-lock-p)) (>= (inactivity-seconds) +inactivity-timeout-seconds+)) (lock-runner)) t))))
(defun stop-inactivity-monitor () (when *inactivity-source-id* (glib:source-remove *inactivity-source-id*) (setf *inactivity-source-id* nil)))
(defun install-activity-monitor (window web-view) "Reset inactivity on pointer motion, clicks, and keyboard input." (let ((motion (make-event-controller-motion)) (click (make-gesture-click)) (key (make-event-controller-key))) (dolist (controller (list motion click key)) (setf (event-controller-propagation-phase controller) +propagation-phase-capture+) (widget-add-controller window controller)) (connect motion "motion" (lambda (controller x y) (declare (ignore controller x y)) (note-user-activity window web-view))) (connect click "pressed" (lambda (gesture n-press x y) (declare (ignore gesture n-press x y)) (note-user-activity window web-view))) (connect key "key-pressed" (lambda (controller keyval keycode state) (declare (ignore controller keyval keycode state)) (note-user-activity window web-view) nil))))
(defun pin-verifier-path () (merge-pathnames "pin-verifier" (runner-data-directory)))
(defun read-pin-verifier () (when (probe-file (pin-verifier-path)) (ensure-private-directory (runner-data-directory)) (restrict-file-to-owner (pin-verifier-path)) (with-open-file (stream (pin-verifier-path) :direction :input) (read-line stream nil nil))))
(defun remove-profiles-without-pin-verifier () "Delete saved profiles when their PIN verifier has been removed.
A missing verifier with existing profiles would otherwise let the next launcherset a replacement PIN and open the saved authenticated sessions." (let ((directories (list (runner-profiles-data-directory) (runner-profiles-cache-directory)))) (when (some #'probe-file directories) (dolist (directory directories) (when (probe-file directory) (uiop:delete-directory-tree directory :validate t))) t)))
(defun six-digit-pin-p (pin) (and (= (length pin) 6) (every #'digit-char-p pin)))
(defun save-pin (pin) (ensure-private-directory (runner-data-directory)) (with-open-file (stream (pin-verifier-path) :direction :output :if-exists :supersede :if-does-not-exist :create) (write-line (ironclad:pbkdf2-hash-password-to-combined-string (ironclad:ascii-string-to-byte-array pin) :iterations +pin-iterations+) stream)) (restrict-file-to-owner (pin-verifier-path)))
(defun pin-valid-p (pin verifier) (and (six-digit-pin-p pin) verifier (ironclad:pbkdf2-check-password (ironclad:ascii-string-to-byte-array pin) verifier)))
(defun make-web-view-with-network-session (session) "Create a WebView with SESSION as its construct-only network session property." (cffi:with-foreign-object (property-names :pointer 1) (cffi:with-foreign-string (network-session-name "network-session") (cffi:with-foreign-object (value '(:struct g-value)) (cffi:foreign-funcall "memset" :pointer value :int 0 :size (cffi:foreign-type-size '(:struct g-value)) :pointer) (unwind-protect (progn (setf (cffi:mem-aref property-names :pointer 0) network-session-name) (%g-value-init value (%webkit-network-session-get-type)) (%g-value-set-object value (gir-wrapper:object-pointer session)) (gir-wrapper:pointer-object (%g-object-new-with-properties (%webkit-web-view-get-type) 1 property-names value) 'webkit:web-view)) (%g-value-unset value))))))
(defun delete-persistent-cookies () "Remove the explicit cookie database and its SQLite sidecar files." (let ((cookie-file (merge-pathnames "cookies.sqlite" (profile-data-directory)))) (dolist (path (list cookie-file (pathname (format nil "~A-wal" cookie-file)) (pathname (format nil "~A-shm" cookie-file)))) (when (probe-file path) (delete-file path)))))
(defun delete-isolated-webkit-directories () (dolist (directory (list (profile-data-directory) (profile-cache-directory))) (when (probe-file directory) (uiop:delete-directory-tree directory :validate t))))
(defun clear-website-data (&optional completion) "Asynchronously clear data from this runner's isolated WebKit session." (setf *website-data-clear-completion* completion) (%webkit-website-data-manager-clear (gir-wrapper:object-pointer (webkit:network-session-website-data-manager *network-session*)) webkit:+website-data-types-all+ 0 (cffi:null-pointer) (cffi:callback website-data-cleared) (cffi:null-pointer)))
(defun clear-website-data-and-wait () "Clear data while keeping a GLib loop alive long enough for completion." (let ((loop (glib:make-main-loop :context nil :is-running nil)) (completedp nil)) (clear-website-data (lambda (successp) (setf completedp t) (when successp (delete-isolated-webkit-directories)) (glib:main-loop-quit loop))) (glib:timeout-add-seconds 15 (lambda () (glib:main-loop-quit loop) nil)) (glib:main-loop-run loop) (unless completedp (format *error-output* "Timed out while clearing runner data; retaining the profile.~%"))))
(defun make-pin-window (application on-unlock) "Show PIN setup on first run and an unlock prompt thereafter." (let* ((verifier (read-pin-verifier)) (profiles-removed-p (and (null verifier) (remove-profiles-without-pin-verifier))) (setting-up-p (null verifier)) (window (make-application-window :application application)) (container (make-box :orientation +orientation-vertical+ :spacing 12)) (prompt (make-label :str (if setting-up-p "Create a six-digit PIN to protect saved sessions" "Enter your six-digit PIN to unlock saved sessions"))) (pin-entry (make-entry)) (confirm-entry (make-entry)) (status (make-label :str (if profiles-removed-p "Saved runner profiles were removed because the PIN verifier is missing." ""))) (submit (make-button :label (if setting-up-p "Set PIN" "Unlock"))) (failed-attempts 0)) (follow-system-color-scheme window) (setf (window-title window) "Unlock Web App Runner" (window-default-size window) '(480 220) (widget-margin-start container) 24 (widget-margin-end container) 24 (widget-margin-top container) 24 (widget-margin-bottom container) 24 (entry-visibility-p pin-entry) nil (entry-visibility-p confirm-entry) nil (entry-placeholder-text pin-entry) "Six-digit PIN" (entry-placeholder-text confirm-entry) "Confirm PIN") (labels ((submitted-pin () (entry-buffer-text (entry-buffer pin-entry))) (unlock () (let ((pin (submitted-pin))) (cond ((not (six-digit-pin-p pin)) (setf (label-text status) "PIN must contain exactly six digits.")) (setting-up-p (if (string= pin (entry-buffer-text (entry-buffer confirm-entry))) (progn (save-pin pin) (window-destroy window) (funcall on-unlock)) (setf (label-text status) "The PIN entries do not match."))) ((pin-valid-p pin verifier) (window-destroy window) (funcall on-unlock)) (t (incf failed-attempts) (if (< failed-attempts 5) (setf (label-text status) "Incorrect PIN.") (progn (setf (label-text status) "Too many attempts. Try again in 30 seconds." (widget-sensitive-p submit) nil) (timeout-add-seconds 30 (lambda () (setf failed-attempts 0 (widget-sensitive-p submit) t (label-text status) "") nil))))))))) (connect pin-entry "activate" (lambda (entry) (declare (ignore entry)) (unlock))) (connect confirm-entry "activate" (lambda (entry) (declare (ignore entry)) (unlock))) (connect submit "clicked" (lambda (button) (declare (ignore button)) (unlock)))) (dolist (widget (append (list prompt pin-entry) (when setting-up-p (list confirm-entry)) (list status submit))) (box-append container widget)) (setf (window-child window) container) (window-present window)))
(defun ensure-lock-overlay-style (widget) "Install the opaque, theme-aware style used by privacy-lock overlays." (unless *lock-css-provider* (let ((provider (make-css-provider))) (css-provider-load-from-string provider (format nil ".runner-lock-overlay { background-color: @window_bg_color; }~% .runner-lock-panel { padding: 32px; border-radius: 12px; }~%")) (style-context-add-provider-for-display (widget-display widget) provider +style-provider-priority-application+) (setf *lock-css-provider* provider))))
(defun unlock-runner () "Remove the privacy overlay from every runner window without reloading WebKit." (setf *runner-locked-p* nil) (note-user-activity) (dolist (lock *runner-locks*) (setf (widget-visible-p (browser-lock-overlay lock)) nil (entry-buffer-text (entry-buffer (browser-lock-pin-entry lock))) "" (label-text (browser-lock-status lock)) "") (update-browser-navigation lock) (widget-grab-focus (browser-lock-web-view lock))))
(defun lock-runner () "Cover every runner window while retaining the live WebKit sessions beneath." (setf *runner-locked-p* t) ;; Credential fields must not remain visible in a separate window while the ;; browser session is privacy-locked. (dolist (window *credential-windows*) (window-destroy window)) (dolist (lock *runner-locks*) (setf (widget-visible-p (browser-lock-overlay lock)) t (entry-buffer-text (entry-buffer (browser-lock-pin-entry lock))) "" (label-text (browser-lock-status lock)) "") (update-browser-navigation lock) (widget-grab-focus (browser-lock-pin-entry lock))))
(defun make-runner-lock (window web-view) "Create an input-blocking privacy overlay for WINDOW's live WEB-VIEW." (ensure-lock-overlay-style window) (let* ((overlay (make-box :orientation +orientation-vertical+ :spacing 16)) (panel (make-box :orientation +orientation-vertical+ :spacing 12)) (title (make-label :str "Runner locked")) (prompt (make-label :str "Enter your six-digit PIN to continue")) (pin-entry (make-entry)) (status (make-label :str "")) (unlock (make-button :label "Unlock")) (lock (make-browser-lock :window window :overlay overlay :pin-entry pin-entry :status status :submit unlock :web-view web-view)) (failed-attempts 0)) (widget-add-css-class overlay "runner-lock-overlay") (widget-add-css-class panel "runner-lock-panel") (setf (widget-hexpand-p overlay) t (widget-vexpand-p overlay) t (widget-halign panel) +align-center+ (widget-valign panel) +align-center+ (entry-visibility-p pin-entry) nil (entry-placeholder-text pin-entry) "Six-digit PIN" (widget-visible-p overlay) nil) (labels ((attempt-unlock () (if (pin-valid-p (entry-buffer-text (entry-buffer pin-entry)) (read-pin-verifier)) (unlock-runner) (progn (incf failed-attempts) (if (< failed-attempts 5) (setf (label-text status) "Incorrect PIN.") (progn (setf (label-text status) "Too many attempts. Try again in 30 seconds." (widget-sensitive-p unlock) nil) (timeout-add-seconds 30 (lambda () (setf failed-attempts 0 (widget-sensitive-p unlock) t (label-text status) "") nil)))))))) (connect pin-entry "activate" (lambda (entry) (declare (ignore entry)) (attempt-unlock))) (connect unlock "clicked" (lambda (button) (declare (ignore button)) (attempt-unlock)))) (dolist (widget (list title prompt pin-entry status unlock)) (box-append panel widget)) (box-append overlay panel) (connect window "destroy" (lambda (destroyed-window) (declare (ignore destroyed-window)) (setf *runner-locks* (delete lock *runner-locks* :test #'eq)))) (push lock *runner-locks*) lock))
(defun synchronize-cookie-toggles (value) (unless *syncing-cookie-checkboxes-p* (let ((*syncing-cookie-checkboxes-p* t)) (setf *forget-cookies-on-close-p* value) (dolist (checkbox *forget-cookie-checkboxes*) (setf (check-button-active-p checkbox) value)) value)))
(defun make-forget-cookies-toggle (window) "Create a toolbar control for the session-wide cookie cleanup policy." (let ((checkbox (make-check-button :label "Clear data on close"))) (setf (check-button-active-p checkbox) *forget-cookies-on-close-p*) (push checkbox *forget-cookie-checkboxes*) (connect checkbox "toggled" (lambda (button) (synchronize-cookie-toggles (check-button-active-p button)))) (connect window "destroy" (lambda (destroyed-window) (declare (ignore destroyed-window)) (setf *forget-cookie-checkboxes* (delete checkbox *forget-cookie-checkboxes* :test #'eq)))) checkbox))
(defun update-window-title (window web-view) (setf (window-title window) (or (and (not (webkit:web-view-loading-p web-view)) (webkit:web-view-title web-view)) (webkit:web-view-uri web-view) "Web App Runner")))
(defun update-browser-navigation (lock) "Synchronize one window's navigation controls with its WebKit view and lock." (let* ((web-view (browser-lock-web-view lock)) (controls (browser-lock-controls lock)) (back (first controls)) (forward (second controls)) (reload (third controls)) (address (fourth controls)) (inhibit-auto-lock (fifth controls)) (lockedp *runner-locked-p*)) (when address (let ((uri (webkit:web-view-uri web-view))) (when uri (setf (entry-buffer-text (entry-buffer address)) uri))) (update-window-title (browser-lock-window lock) web-view)) (when reload (setf (button-icon-name reload) (if (webkit:web-view-loading-p web-view) "process-stop-symbolic" "view-refresh-symbolic"))) (when back (setf (widget-sensitive-p back) (and (not lockedp) (webkit:web-view-can-go-back-p web-view)))) (when forward (setf (widget-sensitive-p forward) (and (not lockedp) (webkit:web-view-can-go-forward-p web-view)))) (when reload (setf (widget-sensitive-p reload) (not lockedp))) (when address (setf (widget-sensitive-p address) (not lockedp))) (when inhibit-auto-lock (setf (widget-sensitive-p inhibit-auto-lock) (not lockedp)))))
(defun credential-copy-field (status entry &key window) "Copy ENTRY's value; update STATUS only while WINDOW is still alive." (handler-case (copy-credential-to-clipboard (entry-buffer-text (entry-buffer entry)) :on-countdown (lambda (remaining) (when (or (null window) (member window *credential-windows* :test #'eq)) (setf (label-text status) (cond ((plusp remaining) (format nil "Copied; clipboard clears in ~D seconds." remaining)) ((zerop remaining) "Clipboard cleared.") (t "Could not clear the clipboard.")))))) (error (condition) (setf (label-text status) (princ-to-string condition)))))
(defun credential-save-fields (status entry-name username-entry password-entry) "Save the values in the credential editor and update STATUS." (handler-case (progn (write-pass-credential entry-name (entry-buffer-text (entry-buffer username-entry)) (entry-buffer-text (entry-buffer password-entry))) (setf (label-text status) "Credential saved.")) (error (condition) (setf (label-text status) (princ-to-string condition)))))
(defun make-credentials-window (application browser-window web-view) "Show explicit copy and save actions for the current host's pass entry." (let* ((window (make-application-window :application application)) (container (make-box :orientation +orientation-vertical+ :spacing 12)) (host (handler-case (url-host (or (webkit:web-view-uri web-view) "https://unknown")) (error () "unknown"))) (entry-name (credential-entry-name-for-host host)) (heading (make-label :str (format nil "Credentials for ~A" host))) (entry-label (make-label :str entry-name)) (username-entry (make-entry)) (password-entry (make-entry)) (show-password (make-check-button :label "Show password")) (save (make-button :label "Save / overwrite")) (username-button (make-button :label "Copy username")) (password-button (make-button :label "Copy password")) (status (make-label :str "No saved credential loaded.")) (close (make-button :label "Close"))) (setf (window-title window) "Runner Credentials" (window-default-size window) '(420 240) (window-transient-for window) browser-window (widget-margin-start container) 24 (widget-margin-end container) 24 (widget-margin-top container) 24 (widget-margin-bottom container) 24 (entry-placeholder-text username-entry) "Username" (entry-placeholder-text password-entry) "Password" (entry-visibility-p password-entry) nil) (push window *credential-windows*) (install-activity-monitor window nil) (connect window "destroy" (lambda (destroyed-window) (declare (ignore destroyed-window)) (setf *credential-windows* (delete window *credential-windows* :test #'eq)))) (handler-case (let ((credential (read-pass-credential entry-name))) (setf (entry-buffer-text (entry-buffer username-entry)) (or (password-credential-username credential) "") (entry-buffer-text (entry-buffer password-entry)) (password-credential-password credential) (label-text status) "Saved credential loaded.")) (error (condition) (setf (label-text status) (format nil "No saved credential: ~A" condition)))) (connect show-password "toggled" (lambda (button) (setf (entry-visibility-p password-entry) (check-button-active-p button)))) (connect save "clicked" (lambda (button) (declare (ignore button)) (credential-save-fields status entry-name username-entry password-entry))) (connect username-button "clicked" (lambda (button) (declare (ignore button)) (credential-copy-field status username-entry :window window))) (connect password-button "clicked" (lambda (button) (declare (ignore button)) (credential-copy-field status password-entry :window window))) (connect close "clicked" (lambda (button) (declare (ignore button)) (window-destroy window))) (dolist (widget (list heading entry-label username-entry password-entry show-password save username-button password-button status close)) (box-append container widget)) (setf (window-child window) container) (window-present window)))
(defun make-browser-window (application url) (let* ((window (make-application-window :application application)) (web-view (make-web-view-with-network-session *network-session*)) (container (make-box :orientation +orientation-vertical+ :spacing 0)) ;; GtkHeaderBar follows the desktop's light/dark theme and updates ;; when that theme changes, unlike a manually styled title bar. (header (make-header-bar)) (back (make-button :icon-name "go-previous-symbolic")) (forward (make-button :icon-name "go-next-symbolic")) (reload (make-button :icon-name "view-refresh-symbolic")) (address (make-entry)) (inhibit-auto-lock (make-check-button :label "Keep unlocked")) (credentials-button (when (pass-available-p) (make-button :icon-name "dialog-password-symbolic"))) (lock-button (make-button :icon-name "system-lock-screen-symbolic")) (forget-cookies (make-forget-cookies-toggle window)) (lock-overlay (make-runner-lock window web-view)) (content-overlay (make-overlay))) (push web-view *web-views*) (push (cons window address) *browser-addresses*) (setf (browser-lock-controls lock-overlay) (list back forward reload address inhibit-auto-lock)) (install-activity-monitor window web-view) (note-user-activity window web-view) (install-location-shortcut window address web-view) (connect window "destroy" (lambda (destroyed-window) (declare (ignore destroyed-window)) (setf *web-views* (delete web-view *web-views* :test #'eq) *browser-addresses* (delete window *browser-addresses* :key #'car :test #'eq)))) (setf (window-default-size window) '(1280 900) (window-title window) "Web App Runner" (header-bar-show-title-buttons-p header) t (header-bar-title-widget header) address (window-titlebar window) header (widget-hexpand-p address) t (widget-hexpand-p web-view) t (widget-vexpand-p web-view) t (widget-tooltip-text inhibit-auto-lock) "Prevent automatic locking for this website" (widget-tooltip-text lock-button) "Lock (Ctrl+Shift+L)") (when credentials-button (setf (widget-tooltip-text credentials-button) "Credentials (Ctrl+Shift+P)")) (dolist (widget (remove nil (list back forward reload credentials-button))) (header-bar-pack-start header widget)) (header-bar-pack-end header forget-cookies) (header-bar-pack-end header inhibit-auto-lock) (header-bar-pack-end header lock-button) (box-append container web-view) (setf (overlay-child content-overlay) container) (overlay-add-overlay content-overlay (browser-lock-overlay lock-overlay)) (setf (window-child window) content-overlay) (connect inhibit-auto-lock "toggled" (lambda (button) (setf (browser-lock-inhibit-auto-lock-p lock-overlay) (check-button-active-p button)) (note-user-activity window web-view))) (connect lock-button "clicked" (lambda (button) (declare (ignore button)) (lock-runner))) (when credentials-button (connect credentials-button "clicked" (lambda (button) (declare (ignore button)) (unless *runner-locked-p* (make-credentials-window application window web-view))))) (connect back "clicked" (lambda (button) (declare (ignore button)) (webkit:web-view-go-back web-view))) (connect forward "clicked" (lambda (button) (declare (ignore button)) (webkit:web-view-go-forward web-view))) (connect reload "clicked" (lambda (button) (declare (ignore button)) (if (webkit:web-view-loading-p web-view) (webkit:web-view-stop-loading web-view) (webkit:web-view-reload web-view)))) (connect address "activate" (lambda (entry) (webkit:web-view-load-uri web-view (normalize-url (entry-buffer-text (entry-buffer entry)))))) (connect web-view "load-changed" (lambda (view event) (declare (ignore view event)) (update-browser-navigation lock-overlay))) ;; Web apps often navigate with History API changes that do not emit ;; load-changed; property notifications keep the address and history ;; buttons current for those transitions too. (dolist (signal '("notify::uri" "notify::can-go-back" "notify::can-go-forward")) (connect web-view signal (lambda (view property) (declare (ignore view property)) (update-browser-navigation lock-overlay)))) (update-browser-navigation lock-overlay) (webkit:web-view-load-uri web-view url) (window-present window)))
(defun start-browser-session (application urls) "Create the target-specific WebKit profile after the PIN has been accepted." (note-user-activity) (setf *profile-key* (profile-key-for-urls urls) *network-session* (make-persistent-network-session)) (dolist (url urls) (make-browser-window application url)))
(defun install-keyboard-shortcuts (application) "Install runner-wide Lock and focus-location keyboard shortcuts." (cffi:use-foreign-library gtk4) (labels ((register-shortcut (name accelerator function) (let ((action (gio:make-simple-action :name name :parameter-type nil))) (connect action "activate" (lambda (activated-action parameter) (declare (ignore activated-action parameter)) (funcall function))) (gio:action-map-add-action application action) (cffi:with-foreign-string (accelerator-string accelerator) (cffi:with-foreign-object (accelerators :pointer 2) (setf (cffi:mem-aref accelerators :pointer 0) accelerator-string (cffi:mem-aref accelerators :pointer 1) (cffi:null-pointer)) (%gtk-application-set-accels-for-action (gir-wrapper:object-pointer application) (format nil "app.~A" name) accelerators)))))) (register-shortcut "lock" "<Control><Shift>l" #'lock-runner) (when (pass-available-p) (register-shortcut "credentials" "<Control><Shift>p" (lambda () (when (and *active-browser-window* *active-browser-web-view* (not *runner-locked-p*)) (make-credentials-window application *active-browser-window* *active-browser-web-view*)))))))
(defun install-location-shortcut (window address web-view) "Capture Ctrl+L before WebKit consumes it and focus ADDRESS." (let ((controller (make-event-controller-key))) (setf (event-controller-propagation-phase controller) +propagation-phase-capture+) (connect controller "key-pressed" (lambda (key-controller keyval keycode state) (declare (ignore key-controller keycode)) (note-user-activity window web-view) ;; GDK_CONTROL_MASK is bit 2. GDK keyvals for lowercase L use ;; its Unicode code point; Ctrl+L has no Shift modifier. (when (and (= keyval (char-code #\l)) (not (zerop (logand state 4)))) (widget-grab-focus address) (editable-select-region address 0 -1) t))) (widget-add-controller window controller)))
(defun make-url-prompt-window (application) "Show saved runners and a custom URL prompt when no URL was supplied." (let* ((window (make-application-window :application application)) (container (make-box :orientation +orientation-vertical+ :spacing 12)) (saved-runners (saved-runner-urls)) (saved-prompt (make-label :str "Saved runners")) (prompt (make-label :str "Enter a website address")) (entry (make-entry)) (url-controls (make-box :orientation +orientation-horizontal+ :spacing 6)) (error-label (make-label :str "")) (open (make-button :label "Open"))) (setf (window-title window) "Open Website" (window-default-size window) '(480 360) (widget-margin-start container) 24 (widget-margin-end container) 24 (widget-margin-top container) 24 (widget-margin-bottom container) 24 (widget-hexpand-p entry) t (widget-margin-top saved-prompt) 12) (labels ((open-url (url) (handler-case (progn (start-browser-session application (list url)) (window-destroy window)) (error (condition) (setf (label-text error-label) (princ-to-string condition))))) (open-custom-url () (handler-case (open-url (normalize-url (entry-buffer-text (entry-buffer entry)))) (error (condition) (setf (label-text error-label) (princ-to-string condition)))))) (connect entry "activate" (lambda (widget) (declare (ignore widget)) (open-custom-url))) (connect open "clicked" (lambda (button) (declare (ignore button)) (open-custom-url))) (box-append url-controls entry) (box-append url-controls open) (dolist (widget (list prompt url-controls error-label)) (box-append container widget)) (when saved-runners (box-append container saved-prompt) (dolist (url saved-runners) (let* ((selected-url url) (runner (make-button :label selected-url))) (connect runner "clicked" (lambda (button) (declare (ignore button)) (open-url selected-url))) (box-append container runner))))) (setf (window-child window) container) (window-present window)))
(defun run (urls) "Unlock the persistent profile, then open URLS." (setf *forget-cookies-on-close-p* nil *forget-cookie-checkboxes* nil *web-views* nil *profile-key* nil *network-session* nil *runner-locked-p* nil *runner-locks* nil *browser-addresses* nil *credential-windows* nil *active-browser-window* nil *active-browser-web-view* nil *last-user-activity-time* 0 *inactivity-source-id* nil) (let ((application (make-application :application-id +application-id+ :flags gio:+application-flags-non-unique+))) (unwind-protect (progn (install-keyboard-shortcuts application) (start-inactivity-monitor) (connect application "activate" (lambda (app) (make-pin-window app (lambda () (if urls (start-browser-session app urls) (make-url-prompt-window app)))))) (application-run application nil)) (stop-inactivity-monitor) (when (and *forget-cookies-on-close-p* *network-session*) (clear-website-data-and-wait)))))
(defun main () "Executable entry point." (let ((urls (parse-command-line (uiop:command-line-arguments)))) (if (eq urls :help) (format t "~A" +usage+) (run urls))))