Keep the Emacs server running in the Emacs in the current active systemd session

server-sucker.el

;; Copyright 2023 Jonathan Kamens <jik@kamens.us>.
;;
;; This program is free software: you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by the Free
;; Software Foundation, either version 3 of the License, or (at your option)
;; any later version. See <https://www.gnu.org/licenses/>.
;;
;; This program is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
;; more details.

;; Keep the Emacs server running on the currently active systemd session
;;
;; To make this work, we need to do three things:
;; 1. Know what session we're running in.
;; 2. Know when our session becomes active.
;; 3. Know whether the server socket is the one we created.
;;
;; We keep the following state:
;; 1. The identifier of the session we're running in.
;; 2. The inode of the server socket immediately after we created it.
;; 3. The IdleHint from our session.
;; 4. The timer identifier.
;;
;; Every time our timer callback runs, we do the following:
;; 1. Check if we've switched from idle to active and stop if not.
;; 2. Store current idle hint.
;; 3. Check if the server socket matches our stored inode and stop if so.
;; 4. Start the server.
;; 5. Store the server socket's inode.

(provide 'server-sucker)

(defvar server-sucker-session-id nil)
(defvar server-sucker-inode nil)
(defvar server-sucker-idle-hint nil)
(defvar server-sucker-timer nil)

(setq server-sucker-log-name "*server-sucker-log*")

(defun server-sucker-log (&rest args)
  (save-excursion
    (set-buffer (get-buffer-create server-sucker-log-name))
    (let ((message (apply 'format args))
          ;; I don't understand why it's necessary to save point here and
          ;; restore it explicitly below. As far as I can tell from the
          ;; documentation `save-excursion` is supposed to do that, but it's
          ;; not.
          (current (point)))
      (goto-char (point-max))
      (insert (current-time-string))
      (insert ": ")
      (insert message)
      (when (not (string-match-p "\n$" message))
        (insert "\n"))
      (goto-char current))))

(defun get-systemd-session-id ()
  (with-temp-buffer
    ;; I honestly don't understand why there isn't a loginctl mode that returns
    ;; the caller's session in human-readable format.
    (call-process "loginctl" nil (current-buffer) nil "session-status")
    (goto-char (point-min))
    (looking-at "[0-9]+")
    (let ((session-id (match-string 0)))
      (server-sucker-log "get-systemd-session-id: %s" session-id)
      session-id)))

(defun get-systemd-idle-hint (&optional session-id)
  (when (or session-id (setq session-id (get-systemd-session-id)))
    (with-temp-buffer
      (call-process "loginctl" nil (current-buffer) nil "show-session"
                    session-id)
      (goto-char (point-min))
      (search-forward-regexp "IdleHint=\\(.+\\)")
      (let ((idle-hint (match-string 1)))
        (server-sucker-log "get-systemd-idle-hint: %s" idle-hint)
        idle-hint))))

(defun get-server-socket-inode ()
  (let* ((server-socket (cadr (process-contact server-process)))
         (attributes (file-attributes server-socket))
         (inode (file-attribute-inode-number attributes)))
    (server-sucker-log "get-server-socket-inode: socket=%s inode=%d"
                       server-socket inode)
    inode))

(defun suck-server ()
  (with-current-buffer (get-buffer-create server-sucker-log-name)
    (erase-buffer))
  (when (server-running-p)
    (server-sucker-log "suck-server: server-force-delete")
    (server-force-delete))
    (server-sucker-log "suck-server: server-start")
  (server-start)
  (setq server-sucker-inode (get-server-socket-inode)))

(defun server-sucker-callback ()
  (catch 'return
    (let ((new-idle-hint (get-systemd-idle-hint server-sucker-session-id))
          (old-idle-hint server-sucker-idle-hint))
      (setq server-sucker-idle-hint new-idle-hint)
      (when (not (and (equal old-idle-hint "yes")
                      (equal new-idle-hint "no")))
        (server-sucker-log
         "server-sucker-callback: server-sucker-idle-hint=%s new-idle-hint=%s"
         server-sucker-idle-hint new-idle-hint)
        (throw 'return nil)))
    (let ((new-inode (get-server-socket-inode)))
      (when (not (equal new-inode server-sucker-inode))
        (suck-server)
        (throw 'return nil)))
    (server-sucker-log
     "server-sucker-callback: new-inode=%d server-sucker-inode=%d"
     new-inode server-sucker-inode)))

(suck-server)
(setq server-sucker-session-id (get-systemd-session-id))
(setq server-sucker-idle-hint (get-systemd-idle-hint server-sucker-session-id))
(when server-sucker-timer
  (cancel-timer server-sucker-timer))
(setq server-sucker-timer (run-at-time "0" 5 'server-sucker-callback))