branch: elpa/hyperdrive
commit c33cf48e01e9dd1bd07759f1753a395280583a85
Author: Adam Porter <[email protected]>
Commit: Joseph Turner <[email protected]>
Refactor: Gateway status things
---
hyperdrive-lib.el | 215 ++++++++++++++++++-----------------------------------
hyperdrive-menu.el | 2 +-
hyperdrive-vars.el | 37 ++++++++-
hyperdrive.el | 45 +++++------
4 files changed, 131 insertions(+), 168 deletions(-)
diff --git a/hyperdrive-lib.el b/hyperdrive-lib.el
index 58c0e5918f..283293b6f5 100644
--- a/hyperdrive-lib.el
+++ b/hyperdrive-lib.el
@@ -239,14 +239,6 @@ PLZ-ERR should be a `plz-error' struct."
(_
(signal 'plz-error (list "plz error" plz-err)))))
-;;;###autoload
-(defun hyperdrive-status ()
- "Return non-nil if `hyper-gateway-ushin' is running and accessible."
- ;; FIXME: Ensure a very short timeout for this request.
- (condition-case nil
- (plz 'get (format "http://localhost:%d/"; h/hyper-gateway-ushin-port))
- (error nil)))
-
(defun h//httpify-url (url)
"Return localhost HTTP URL for HYPER-URL."
(format "http://localhost:%d/hyper/%s";
@@ -1420,97 +1412,6 @@ Then calls THEN if given."
;;;; Gateway process
-;; NOTE: The below involves some slightly hacky workarounds due to using a
-;; setter for the `h/gateway-process-type' option. The setter gets called
-;; unexpectedly early in the compilation and/or load process, which causes
-;; errors if the functions/methods and variables involved are not yet defined.
-;; So we define the variable first, giving it a nil value, and define a default
-;; for the running-p method (because the setter gets called before the option
is
-;; given its default value), and then the variable is redefined as an option
and
-;; given its default value.
-
-(defvar h/gateway-process-type nil)
-
-(cl-defmethod h//gateway-running-p ()
- "Return non-nil if the gateway process is running.")
-
-(cl-defmethod h//gateway-running-p (&context (h/gateway-process-type (eql
'systemd)))
- "Return non-nil if the gateway process is running.
-This does not mean that the gateway is responsive, only that the
-process is running. Used when HYPERDRIVE-GATEWAY-PROCESS-TYPE
-is the symbol `systemd'."
- (zerop (call-process "systemctl" nil nil nil
- "--user" "is-active" "hyper-gateway-ushin.service")))
-
-(cl-defmethod h//gateway-running-p (&context (h/gateway-process-type (eql
'subprocess)))
- "Return non-nil if the gateway process is running.
-This does not mean that the gateway is responsive, only that the
-process is running. Used when HYPERDRIVE-GATEWAY-PROCESS-TYPE
-is the symbol `subprocess'."
- (process-live-p h/gateway-process))
-
-(defcustom h/gateway-process-type nil
- "How to run the gateway process.
-Value may be one of
-
-- nil :: Autodetect
-- \\+`systemd' :: systemd user-level service
-- \\+`subprocess' :: Emacs subprocess
-
-To customize the command run as a subprocess, see
-`hyperdrive-gateway-command'."
- ;; TODO: Can or should we use the :initialize function here?
- :set (lambda (option value)
- "Stop the gateway process before changing the type."
- (let ((value-changing-p (not (equal h/gateway-process-type value))))
- (unless value
- ;; Try to autodetect whether the gateway is already installed as a
- ;; systemd service. (If systemd is not installed, it will
default to
- ;; `subprocess'.)
- (setf value
- (if (ignore-errors
- (zerop (call-process
- "systemctl" nil nil nil "--user" "is-enabled"
- "hyper-gateway-ushin.service")))
- 'systemd
- 'subprocess)))
- (let ((runningp (h//gateway-running-p)))
- (when (and runningp value-changing-p)
- (h//gateway-stop))
- (set-default option value)
- (when (and runningp value-changing-p)
- (h//gateway-start)))))
- :type '(choice (const :tag "systemd service" systemd)
- (const :tag "Emacs subprocess"
- :description "When Emacs exits, the gateway will be
terminated."
- subprocess)
- (const :tag "Autodetect" nil))
- :group 'hyperdrive)
-
-(defcustom h/gateway-command-args "run --writable true --silent true"
- ;; TODO: File Emacs bug report because the customization formatter handles
the
- ;; "symbol `subprocess'" part differently than `describe-variable' does.
- "Arguments passed to hyper-gateway-ushin.
-Only used when `hyperdrive-gateway-process-type' is the symbol `subprocess'."
- :type 'string
- :group 'hyperdrive)
-
-(cl-defmethod h//gateway-start (&context (h/gateway-process-type (eql
'systemd)))
- "Start the gateway as a systemd service.
-Used when HYPERDRIVE-GATEWAY-PROCESS-TYPE is the symbol
-`systemd'."
- (when (h//gateway-running-p)
- (user-error "Gateway already running"))
- (let ((buffer (get-buffer-create " *hyperdrive-start*")))
- (unwind-protect
- (unless (zerop (call-process
- "systemctl" nil (list buffer t) nil
- "--user" "start" "hyper-gateway-ushin.service"))
- (h/error "Unable to start hyper-gateway-ushin: %S"
- (with-current-buffer buffer
- (string-trim-right (buffer-string)))))
- (kill-buffer buffer))))
-
(defun h//hyper-gateway-ushin-path ()
"Return path to hyper-gateway-ushin executable, or nil if not found."
(cond ((file-exists-p
@@ -1518,19 +1419,22 @@ Used when HYPERDRIVE-GATEWAY-PROCESS-TYPE is the symbol
(expand-file-name "hyper-gateway-ushin" hyperdrive-gateway-directory))
((executable-find "hyper-gateway-ushin"))))
-(cl-defmethod h//gateway-start
- (&context (h/gateway-process-type (eql 'subprocess)))
+(defun h//gateway-start-default ()
"Start the gateway as an Emacs subprocess.
-Used when HYPERDRIVE-GATEWAY-PROCESS-TYPE is the symbol
-`subprocess'."
- (when (h//gateway-running-p)
- (user-error "Gateway already running"))
+Default function; see variable `h/gateway-start-function'."
+ (cond ((and (h//gateway-ready-p)
+ (h//gateway-live-p))
+ (h/error "Gateway already running"))
+ ((h//gateway-ready-p)
+ (h/error "Gateway already running outside of Emacs"))
+ ((h//gateway-live-p)
+ (h/error "Gateway already starting")))
(let ((hyper-gateway-ushin-path
(or (h//hyper-gateway-ushin-path)
(if (yes-or-no-p "hyper-gateway-ushin not installed; install? ")
(h/install)
(h/error "Gateway not installed; aborted")))))
- (when (defvar h/install-in-progress-p)
+ (when h/install-in-progress-p
(h/error "Gateway installation in-progress"))
(setf h/gateway-process
(make-process
@@ -1539,48 +1443,71 @@ Used when HYPERDRIVE-GATEWAY-PROCESS-TYPE is the symbol
:command (cons hyper-gateway-ushin-path
(split-string-and-unquote h/gateway-command-args))
:connection-type 'pipe))
- (sleep-for 0.5)
- (unless (process-live-p h/gateway-process)
- (if (h/status)
- (user-error "Gateway is already running outside of Emacs (see option
`hyperdrive-gateway-process-type')")
- (pop-to-buffer " *hyperdrive-start*")
- (h/error "Gateway failed to start (see process buffer for errors)")))))
-
-(cl-defmethod h//gateway-stop (&context (h/gateway-process-type (eql
'systemd)))
- "Stop the gateway service.
-Used when HYPERDRIVE-GATEWAY-PROCESS-TYPE is the symbol
-`systemd'."
- (unless (h//gateway-running-p)
- (user-error "Gateway not running"))
- (let ((buffer (get-buffer-create " *hyperdrive-stop*")))
- (unwind-protect
- (unless (zerop (call-process "systemctl" nil (list buffer t) nil
- "--user" "stop"
"hyper-gateway-ushin.service"))
- (h/error "Unable to stop hyper-gateway-ushin: %S"
- (with-current-buffer buffer
- (string-trim-right (buffer-string)))))
- (cl-loop for i below 40
- do (sleep-for 0.1)
- while (h//gateway-running-p))
- (when (h//gateway-running-p)
- (h/error "Gateway still running"))
- (kill-buffer buffer))))
-
-(cl-defmethod h//gateway-stop (&context (h/gateway-process-type (eql
'subprocess)))
- "Stop the gateway subprocess.
-Used when HYPERDRIVE-GATEWAY-PROCESS-TYPE is the symbol
-`subprocess'."
- (unless (h//gateway-running-p)
- (user-error "Gateway not running"))
+ (h/message "Starting gateway...")
+ ;; TODO: Update hyperdrive-menu to indicate "gateway starting...".
+ (h//gateway-wait-for-ready)))
+
+(defun h//gateway-after-start-announce ()
+ "Announce that the gateway is ready."
+ ;; TODO: Update hyperdrive-menu to indicate "gateway ready".
+ (h/message "Gateway ready."))
+
+(defun h//gateway-stop-default ()
+ "Stop the gateway subprocess."
+ (unless (h//gateway-live-p)
+ ;; NOTE: We do not try to stop the process if we didn't start it ourselves.
+ (h/error "Gateway not running as subprocess"))
(interrupt-process h/gateway-process)
- (cl-loop for i below 40
- do (sleep-for 0.1)
- while (h//gateway-running-p))
- (when (h//gateway-running-p)
- (h/error "Gateway still running"))
+ (with-timeout (4 (h/error "Gateway still running"))
+ (cl-loop while (h//gateway-live-p)
+ do (sleep-for 0.2)))
+ ;; TODO: Consider killing the process buffer and setting the variable nil in
+ ;; the sentinel.
(kill-buffer (process-buffer h/gateway-process))
(setf h/gateway-process nil))
+(defun h//gateway-live-p ()
+ "Return non-nil if the gateway process is running.
+Calls function set in option `hyperdrive-gateway-live-predicate'.
+This does not mean that the gateway is responsive, only that the
+process is running. See also function
+`hyperdrive--gateway-ready-p'."
+ (funcall h/gateway-live-predicate))
+
+(defun h//gateway-live-p-default ()
+ "Return non-nil if the gateway process is running.
+This does not mean that the gateway is responsive, only that the
+process is running. See also function
+`hyperdrive--gateway-ready-p'."
+ (process-live-p h/gateway-process))
+
+(defun h//gateway-ready-p ()
+ "Return non-nil if the gateway is running and accessible.
+Times out after 2 seconds."
+ (ignore-errors
+ (plz 'get (format "http://localhost:%d/"; h/hyper-gateway-ushin-port)
+ :connect-timeout 2 :timeout 2)))
+
+(defun h//gateway-wait-for-ready ()
+ "Run `hyperdrive-gateway-ready-hook' after gateway is ready.
+Or if gateway isn't ready within timeout, show an error."
+ (letrec
+ ((start-time (float-time))
+ (check
+ (lambda ()
+ (cond ((h//gateway-live-p)
+ (run-hooks 'h/gateway-ready-hook))
+ ((h//gateway-ready-p)
+ ;; Gateway is responsive, so must be running from outside
Emacs.
+ (run-hooks 'h/gateway-ready-hook)
+ (h/message "Gateway is already running outside of Emacs"))
+ ((> 10 (time-subtract (float-time) start-time))
+ ;; Gateway still not responsive: show error.
+ (pop-to-buffer " *hyperdrive-start*")
+ (h/error "Gateway failed to start (see process buffer for
errors)"))
+ (t (run-at-time 0.1 nil check))))))
+ (funcall check)))
+
;;;; Misc.
(defun h//get-buffer-create (entry)
diff --git a/hyperdrive-menu.el b/hyperdrive-menu.el
index f0c89acbf8..fa529e2455 100644
--- a/hyperdrive-menu.el
+++ b/hyperdrive-menu.el
@@ -205,7 +205,7 @@
:description
(lambda ()
(concat (propertize "Gateway: " 'face 'transient-heading)
- (propertize (if (h/status) "on" "off")
+ (propertize (if (h//gateway-ready-p) "on" "off")
'face 'transient-value)))
("G s" "Start" h/start
:transient t)
diff --git a/hyperdrive-vars.el b/hyperdrive-vars.el
index bf46ef988c..bd8a441c4b 100644
--- a/hyperdrive-vars.el
+++ b/hyperdrive-vars.el
@@ -370,8 +370,10 @@ May also be non-nil if the user has chosen to use whatever
version is currently installed.")
(defvar h/gateway-process nil
- "Hyper-gateway-ushin process.
-Only used when `hyperdrive-gateway-process-type' is `subprocess'.")
+ "Hyper-gateway-ushin process.")
+
+(defvar h/install-in-progress-p nil
+ "Non-nil while hyperdrive is installing or upgrading the gateway.")
(defvar-local h/current-entry nil
"Entry for current buffer.")
@@ -403,6 +405,37 @@ Keys are regexps matched against MIME types.")
:desc "Name"))
"Fields for sorting hyperdrive directory buffer columns.")
+(declare-function h//gateway-start-default "hyperdrive-lib")
+(defcustom h/gateway-start-function #'h//gateway-start-default
+ "Function called to start the gateway.
+Should call `hyperdrive--gateway-wait-for-ready' after starting
+the gateway process."
+ :type 'function)
+
+(declare-function h//gateway-stop-default "hyperdrive-lib")
+(defcustom h/gateway-stop-function #'h//gateway-stop-default
+ "Function called to stop the gateway.
+This function should signal an error if it fails to stop the
+gateway process."
+ :type 'function)
+
+(declare-function h//gateway-live-p-default "hyperdrive-lib")
+(defcustom h/gateway-live-predicate #'h//gateway-live-p-default
+ "Predicate function which returns non-nil if the gateway process is live."
+ :type 'function)
+
+(defcustom h/gateway-ready-hook
+ '(h//gateway-after-start-announce)
+ "Hook called when gateway is ready after starting it.
+This hook is called by `hyperdrive--gateway-wait-for-ready' after
+`hyperdrive-start'."
+ :type 'hook)
+
+(defcustom h/gateway-command-args "run --writable true --silent true"
+ "Arguments passed to hyper-gateway-ushin."
+ :type 'string
+ :group 'hyperdrive)
+
;;;; Footer
(provide 'hyperdrive-vars)
diff --git a/hyperdrive.el b/hyperdrive.el
index 9d69b82366..227e1ac0c8 100644
--- a/hyperdrive.el
+++ b/hyperdrive.el
@@ -96,17 +96,20 @@
;;;###autoload
(defun hyperdrive-start ()
"Start `hyper-gateway-ushin' if not already running.
-Customize behavior with `hyperdrive-gateway-process-type', which see."
+Calls function set in option `hyperdrive-gateway-start-function',
+which see."
(interactive)
;; TODO: Verify that the expected version, e.g., 3.7.0, is installed.
- (h//gateway-start))
+ (funcall h/gateway-start-function))
;;;###autoload
(defun hyperdrive-stop ()
"Stop `hyper-gateway-ushin' if running.
-Customize behavior with `hyperdrive-gateway-process-type', which see."
+Calls function set in option `hyperdrive-gateway-stop-function',
+which see."
(interactive)
- (h//gateway-stop))
+ (funcall h/gateway-stop-function)
+ (h/message "Gateway stopped."))
;;;###autoload
(defun hyperdrive-hyper-gateway-ushin-version ()
@@ -816,7 +819,7 @@ The return value of this function is the retrieval buffer."
(defvar h/menu-bar-menu
'(("Gateway"
:label
- (format "Gateway (%s)" (if (h/status) "on" "off"))
+ (format "Gateway (%s)" (if (h//gateway-ready-p) "on" "off"))
["Start Gateway" h/start
:help "Start hyper-gateway-ushin"]
["Stop Gateway" h/stop
@@ -1285,15 +1288,11 @@ Intended for relative (i.e. non-full) URLs."
:sha256 "")))
"Alist mapping `system-type' to URLs where hyper-gateway-ushin can be
downloaded.")
-(defvar h/install-in-progress-p nil
- "Non-nil while hyperdrive is installing or upgrading the gateway.")
-
;;;###autoload
(defun h/install (&optional forcep)
"Install hyper-gateway-ushin.
-Sets `hyperdrive-gateway-process-type' to \\+`subprocess'. If
-FORCEP, force downloading and installing of the expected gateway
-version."
+If FORCEP, force downloading and installing of the expected
+gateway version."
(interactive (list current-prefix-arg))
(when h/install-in-progress-p
(h/error "Installation of gateway already in progress"))
@@ -1335,22 +1334,26 @@ version."
(then file-name)
(try)))
(then (file-name)
- (defvar h/gateway-directory)
- (let ((destination-name (expand-file-name "hyper-gateway-ushin"
h/gateway-directory)))
+ (let ((destination-name
+ (expand-file-name "hyper-gateway-ushin"
h/gateway-directory)))
(when (file-exists-p destination-name)
(move-file-to-trash destination-name))
(unless (file-directory-p h/gateway-directory)
(mkdir h/gateway-directory t))
(rename-file file-name destination-name)
(chmod destination-name #o755))
- ;; NOTE: While `h/gateway-process-type' still exists, this is subtly
- ;; broken, but we will remove that.
- ;; FIXME: Remove `h/gateway-process-type' option.
(setf h/install-in-progress-p nil)
- (if (h//gateway-running-p)
- (when (yes-or-no-p "Installed hyper-gateway-ushin. Restart
gateway?")
- (h/restart))
- (h/message "hyper-gateway-ushin installed. Try
\\[hyperdrive-start]."))))
+ (cond ((h//gateway-live-p)
+ ;; Gateway running inside of Emacs: prompt to restart it.
+ (when (yes-or-no-p "Installed hyper-gateway-ushin. Restart
gateway?")
+ (h/restart)))
+ ((h//gateway-ready-p)
+ ;; Gateway appears to be running outside of Emacs: the user
+ ;; must stop it manually before we can start it.
+ (h/message "New gateway installed but an existing gateway
process is running outside of Emacs; you must manually stop it before the new
version can be started with \\[hyperdrive-start]"))
+ (t
+ ;; Gateway not running: prompt the user to start it.
+ (h/message "hyper-gateway-ushin installed. Try
\\[hyperdrive-start].")))))
(try))))
(defun h/restart ()
@@ -1359,7 +1362,7 @@ version."
(h/message "Restarting gateway...")
(hyperdrive-stop)
(with-timeout (5 (h/message "Timed out waiting for gateway to stop"))
- (cl-loop while (h//gateway-running-p)
+ (cl-loop while (h//gateway-live-p)
do (sleep-for 0.2)))
(hyperdrive-start)
(h/message "Gateway restarted."))
