branch: externals/dtache
commit 7cbd6b35308ffef253f6f76606250f4bf1689c51
Author: Niklas Eklund <niklas.ekl...@posteo.net>
Commit: Niklas Eklund <niklas.ekl...@posteo.net>
Merge remote branch into master
This commit adds support for running dtache in remote shells.
---
README.org | 132 +++--
dtache-shell.el | 165 +++---
dtache.el | 618 ++++++++++++---------
dtache-embark.el => embark-dtache.el | 21 +-
guix.scm | 59 ++
dtache-marginalia.el => marginalia-dtache.el | 63 ++-
test/dtache-shell-test.el | 12 +-
test/dtache-test.el | 207 ++++++-
...arginalia-test.el => marginalia-dtache-test.el} | 48 +-
9 files changed, 862 insertions(+), 463 deletions(-)
diff --git a/README.org b/README.org
index cec405a7ad..09f9924ece 100644
--- a/README.org
+++ b/README.org
@@ -1,88 +1,124 @@
-* About
+#+title: dtache.el - Dtach Emacs
+#+author: Niklas Eklund
+#+language: en
-The ~dtache~ package brings detachable commands to Emacs with the help
-of the external program [[https://linux.die.net/man/1/dtach][dtach]].
Currently it is mainly boosting ~M-x
-shell~ through the ~dtache-shell.el~ package.
+* Introduction
+ :properties:
+ :description: Why Dtache?
+ :end:
-** Background
+ =Dtache= allows a program to be seamlessly executed in an
+ environment that is isolated from =Emacs= which made possible by the
+ [[https://github.com/crigler/dtach][dtach]] program. This package makes sure
that, even though programs
+ are running in isolated sessions, they get tightly integrated with
+ Emacs.
-The package provides the following:
-- allows shell commands to run detached from Emacs
-- access to metadata as well as logs from the sessions
+ The =dtache= package is split up into two, =dtache.el= and
+ =dtache-shell.el=. The former provides the backend implementation,
+ whilst the former provides the integration with =M-x shell=.
+
+** Screenshots
+
+TBD
-** Configuration
+* Configuration
+** Use-package examples
+*** Dtache
-Configure the ~dtache~ package.
+Configuration for the =dtache= package. This package provides the backend for
=dtache=.
#+begin_src elisp
(use-package dtache
+ :hook (after-init . dtache-setup)
:config
- ;; Configure directories for the database as well as sessions
- (setq dtache-db-directory (expand-file-name "dtache" user-emacs-directory))
- (require 'xdg)
- (setq dtache-session-directory (f-join (xdg-runtime-dir) "dtache"))
- ;; Run the setup
- (dtache-setup))
+ (setq dtache-db-directory (no-littering-expand-var-file-name "dtache"))
+ (setq dtache-session-directory (expand-file-name "dtache"
(temporary-file-directory)))
+ (setq dtache-shell-history-file "~/.bash_history")
+ (general-def '(motion normal) dtache-log-mode-map
+ "q" #'quit-window))
#+end_src
-Configure the ~dtache-shell~ package. The ~dtache-shell-enable~ will
-activate the dtache-shell minor mode in shell buffers.
+*** Dtache-shell
+
+Configuration for the =dtache-shell= package. This package provides the
integration with =M-x shell=.
#+begin_src elisp
(use-package dtache-shell
- :hook (after-init . dtache-shell-enable))
+ :hook (shell-mode . dtache-shell-mode)
+ :config
+ (general-def dtache-shell-mode-map
+ "<return>" #'dtache-shell-send-input
+ "<S-return>" #'dtache-shell-create
+ "<C-return>" #'dtache-shell-attach
+ "C-c C-q" #'dtache-shell-detach))
#+end_src
-Configure the keybindings for the minor mode. The choice here is
-either going inclusive on the package replacing the normal behavior of
-shell, or to be more deliberate.
+** Integration with other packages
+*** Embark
+
+Add [[https://github.com/oantolin/embark/][embark]] actions to =dtache=
session commands.
-The following is the evil-bindings for the more adventurous configuration.
#+begin_src elisp
- (general-def dtache-shell-mode-map
- "<return>" #'dtache-shell-create-session
- "<S-return>" #'comint-send-input
- "<C-return>" #'dtache-attach-to-session)
+ (use-package embark-dtache
+ :after (dtache embark))
#+end_src
-You might also want to bind the ~dtache-shell-detach~ to a keybinding
-to be able to quickly detach from a command.
-
-** Optional
+*** Marginalia
-If you are a user of [[https://github.com/minad/marginalia/][marginalia]] and
[[https://github.com/oantolin/embark/][embark]] you might also be
-interested in adding the following to enrich the
-~dtache-attach-to-session~ command. Marginalia adds informative
-annotations and Embark adds quick access to commands to operate on a
-session.
+ Add [[https://github.com/minad/marginalia/][marginalia]] annotations to
enrich the =dtache= session commands.
#+begin_src elisp
- (use-package dtache-marginalia
+ (use-package marginalia-dtache
:after (dtache marginalia)
:config
- (add-to-list 'marginalia-annotators-heavy '(dtache .
dtache-marginalia-annotate)))
+ (add-to-list 'marginalia-annotators-heavy '(dtache .
marginalia-dtache-annotate)))
+#+end_src
- (use-package dtache-embark
- :after (dtache embark))
+** Remote support
+
+The =dtache= package supports
[[https://www.gnu.org/software/emacs/manual/html_node/elisp/Connection-Local-Variables.html][Connection
Local Variables]] which allows the user to change the variables used by
=dtache= when running on a remote host.
+
+#+begin_src elisp
+ (connection-local-set-profile-variables
+ 'remote-dtache
+ '((dtache-shell . "/bin/bash")
+ (dtache-shell-history-file . "~/.bash_history")
+ (dtache-session-directory . "~/tmp")
+ (dtache-program . "/home/user/.local/bin/dtach")))
+
+ (connection-local-set-profiles
+ '(:application tramp :protocol "ssh") 'remote-dtache)
#+end_src
-** Commands
+* Commands
+
+The following is a list of commands that can be run on =dtache= sessions.
+
+** Dtache-shell
+
+Commands to be used in shell buffers.
+
+| Command | Description |
+|-------------------------+--------------------------------------------------|
+| dtache-shell-create | Create a session |
+| dtache-shell-attach | Attach to a session |
+| dtache-shell-detach | Detach from a session |
+| dtache-shell-send-input | Optionally create a session with prefix argument |
+
+** Dtache
-The following is a list of commands that can be run on ~dtache~
-sessions.
+General commands that can be used anywhere.
| Command | Description |
|-----------------------------+---------------------------------------------|
-| dtache-attach-to-session | Attach to a session |
| dtache-open-log | Open the output log for a session |
| dtache-open-stdout | Open the stdout for a session |
| dtache-open-stderr | Open the stderr for a session |
-| dtache-copy-session | Copy the session command |
-| dtache-copy-session-content | Copy the output of a session |
-| dtache-kill-session | Kill an active session |
+| dtache-copy-session-command | Copy the session command |
+| dtache-copy-session-log | Copy the log output of a session |
+| dtache-kill-session | Kill a session |
| dtache-remove-session | Remove a session |
| dtache-compile-session | Open the session output in compilation mode |
-| dtache-shell-create-session | Create a session from a shell command |
* Credits
diff --git a/dtache-shell.el b/dtache-shell.el
index e2031f6689..af149f0b95 100755
--- a/dtache-shell.el
+++ b/dtache-shell.el
@@ -1,11 +1,11 @@
-;;; dtache-shell.el --- Shell integration of dtache -*- lexical-binding: t -*-
+;;; dtache-shell.el --- Dtache integration in shell -*- lexical-binding: t -*-
;; Copyright (C) 2020-2021 Niklas Eklund
;; Author: Niklas Eklund <niklas.ekl...@posteo.net>
;; URL: https://www.gitlab.com/niklaseklund/dtache.git
;; Version: 0.1
-;; Package-Requires: ((emacs "26.1"))
+;; Package-Requires: ((emacs "27.1"))
;; Keywords: convenience processes
;; This file is not part of GNU Emacs.
@@ -25,96 +25,104 @@
;;; Commentary:
-;; This package provides integration of dtache into shell-mode buffers.
-
-;;;; Usage
-
-;; `dtache-shell-enable': Enable dtache in shell buffers
+;; This package provides integration of `dtache' in `shell'.
;;; Code:
+
;;;; Requirements
-(require 'cl-lib)
-(require 'dash)
-(require 'subr-x)
(require 'dtache)
-(require 'comint)
-(require 's)
-(require 'shell)
-;;;; Functions
+;;;; Variables
+
+(defvar dtache-shell-block-list '("^$")
+ "A list of regexps to block non-supported input.")
+(defvar dtache-shell-silence-dtach-messages t
+ "Filter out messages from the `dtach' program.")
-(defun dtache-shell-enable ()
- "Enable `dtache-shell'."
- (add-hook 'shell-mode-hook #'dtache-shell-maybe-activate)
- (advice-add 'shell :around #'dtache-shell--disable-histfile))
+;;;; Functions
-(defun dtache-shell-disable ()
- "Disable `dtache-shell'."
- (remove-hook 'shell-mode-hook #'dtache-shell-maybe-activate)
- (advice-remove 'shell #'dtache-shell--disable-histfile))
+(defun dtache-shell-filter-dtach-eof (string)
+ "Remove eof message from dtach in STRING."
+ (if (string-match dtache-eof-message string)
+ (replace-regexp-in-string (format "%s\n" dtache-eof-message) "" string)
+ string))
-(defun dtache-shell-maybe-activate ()
- "Only local sessions are supported."
- (unless (file-remote-p default-directory)
- (dtache-shell-mode)))
+(defun dtache-shell-filter-dtach-detached (string)
+ "Remove detached message from dtach in STRING."
+ (if (string-match dtache-detached-message string)
+ (replace-regexp-in-string (format "%s\n" dtache-detached-message) ""
string)
+ string))
;;;; Commands
;;;###autoload
-(defun dtache-shell-create-session (&optional disable-block)
- "Create a new dtache session.
-Use prefix argument DISABLE-BLOCK to force the launch of a session."
+(defun dtache-shell-send-input (&optional create-session)
+ "Send input to `shell'.
+
+Optionally CREATE-SESSION with prefix argument."
(interactive "P")
- (let ((comint-input-sender #'dtache-shell-input-sender)
- (dtache-block-list (if disable-block '() dtache-block-list)))
+ (if create-session
+ (dtache-shell-create)
+ (comint-send-input)))
+
+;;;###autoload
+(defun dtache-shell-create ()
+ "Create a session."
+ (interactive)
+ (let ((comint-input-sender #'dtache-shell--create-input-sender))
(comint-send-input)))
;;;###autoload
(defun dtache-shell-detach ()
- "Detach from an attached session."
+ "Detach from session."
(interactive)
(let ((proc (get-buffer-process (current-buffer)))
- (input "\C-\\"))
- (if (dtache-shell--attached-p)
- (comint-simple-send proc input)
- (message "Not attached to a session"))))
-
-(defun dtache-shell-input-sender (proc string)
- "Create a dtache command based on STRING and send to PROC.
-
-The function doesn't create dtache sessions when STRING is matching
-any regexp found in `dtache-block-list'."
- (if-let* ((no-child-process (not (process-running-child-p (get-process
(buffer-name)))))
- (allowed (not (--find (s-matches-p it string) dtache-block-list)))
- (session (dtache-create-session (substring-no-properties string)))
- (command (dtache-session-command session)))
- (comint-simple-send proc command)
- (comint-simple-send proc string)))
-
-;;;; Support functions
-
-(defun dtache-shell--attached-p ()
- "Return t if `shell' is attached to a session."
- (let ((pid (process-running-child-p (get-process (buffer-name)))))
- (when pid
- (let-alist (process-attributes pid)
- (s-equals-p "dtach" .comm)))))
+ (input dtache-detach-character))
+ (comint-simple-send proc input)))
-(defun dtache-shell--filter-dtach-eof (string)
- "Remove eof message from dtach in STRING."
- (if (string-match dtache-eof-message string)
- (s-replace (format "%s\n" (s-replace "\\" "" dtache-eof-message)) ""
string)
- string))
+;;;###autoload
+(defun dtache-shell-attach (session)
+ "Attach to SESSION.
+
+`comint-add-to-input-history' is temporarily disabled to avoid
+cluttering the comint-history with dtach commands."
+ (interactive
+ (list (dtache-select-session)))
+ (if (dtache--session-active-p session)
+ (cl-letf ((dtache--current-session session)
+ (comint-input-sender #'dtache-shell--attach-input-sender)
+ ((symbol-function 'comint-add-to-input-history) (lambda (_)
t)))
+ (comint-kill-input)
+ (comint-send-input))
+ (funcall dtache-attach-alternate-function session)))
-(defun dtache-shell--disable-histfile (orig-fun &rest args)
- "Disable HISTFILE before calling ORIG-FUN with ARGS."
- (cl-letf (((getenv "HISTFILE") ""))
- (apply orig-fun args)))
+;;;; Support functions
-(defun dtache-shell--save-history ()
- "Save `shell' history."
- (comint-write-input-ring))
+(defun dtache-shell--attach-input-sender (proc _string)
+ "Attach to `dtache--session' and send the attach command to PROC."
+ (let* ((socket
+ (concat
+ (dtache--session-session-directory dtache--current-session)
+ (dtache--session-id dtache--current-session)
+ dtache-socket-ext))
+ (input
+ (concat dtache-program " -a " socket)))
+ (comint-simple-send proc input)))
+
+(defun dtache-shell--create-input-sender (proc string)
+ "Create a dtache session based on STRING and send to PROC."
+ (with-connection-local-variables
+ (if-let* ((supported-input
+ (not (seq-find
+ (lambda (blocked)
+ (string-match-p string blocked))
+ dtache-shell-block-list)))
+ (command (dtache-dtach-command
+ (dtache--create-session
+ (substring-no-properties string)))))
+ (comint-simple-send proc command)
+ (comint-simple-send proc string))))
;;;; Minor mode
@@ -123,13 +131,18 @@ any regexp found in `dtache-block-list'."
:lighter "dtache-shell"
:keymap (let ((map (make-sparse-keymap)))
map)
- (if dtache-shell-mode
- (progn
- (dtache-cleanup-sessions)
- (add-hook 'comint-preoutput-filter-functions
#'dtache-shell--filter-dtach-eof 0 t)
- (add-hook 'kill-buffer-hook #'dtache-shell--save-history 0 t))
- (remove-hook 'comint-preoutput-filter-functions
#'dtache-shell--filter-dtach-eof t)
- (remove-hook 'kill-buffer-hook #'dtache-shell--save-history t)))
+ (with-connection-local-variables
+ (if dtache-shell-mode
+ (progn
+ (dtache-db-initialize)
+ (dtache-create-session-directory)
+ (dtache-cleanup-sessions)
+ (when dtache-shell-silence-dtach-messages
+ (add-hook 'comint-preoutput-filter-functions
#'dtache-shell-filter-dtach-eof 0 t)
+ (add-hook 'comint-preoutput-filter-functions
#'dtache-shell-filter-dtach-detached 0 t)))
+ (when dtache-shell-silence-dtach-messages
+ (remove-hook 'comint-preoutput-filter-functions
#'dtache-shell-filter-dtach-eof t)
+ (remove-hook 'comint-preoutput-filter-functions
#'dtache-shell-filter-dtach-detached t)))))
(provide 'dtache-shell)
diff --git a/dtache.el b/dtache.el
index 84e61cd51b..ce7b567cb9 100644
--- a/dtache.el
+++ b/dtache.el
@@ -1,11 +1,11 @@
-;;; dtache.el --- Core dtache -*- lexical-binding: t -*-
+;;; dtache.el --- Dtache core -*- lexical-binding: t -*-
;; Copyright (C) 2020-2021 Niklas Eklund
;; Author: Niklas Eklund <niklas.ekl...@posteo.net>
;; URL: https://www.gitlab.com/niklaseklund/dtache.git
;; Version: 0.1
-;; Package-Requires: ((emacs "26.1"))
+;; Package-Requires: ((emacs "27.1"))
;; Keywords: convenience processes
;; This file is not part of GNU Emacs.
@@ -25,21 +25,21 @@
;;; Commentary:
-;; This package provides a backend implementation for dtache
-;; sessions. Dtache is supposed to be interfaced through other
-;; packages, such a package is `dtache-shell' which brings dtache into
-;; shell buffers.
+;; Dtache allows a program to be seamlessly executed in an environment
+;; that is isolated from Emacs. This package provides the core
+;; implementation. Dtache sessions is supposed to be created and
+;; interacted with through a front end package such as `dtache-shell'.
+
+;; The package requires the program dtach[1] to be installed.
+;;
+;; [1] https://github.com/crigler/dtach
;;; Code:
;;;; Requirements
-(require 'cl-lib)
-(require 'comint)
-(require 'emacsql)
(require 'emacsql-sqlite)
-(require 'f)
-(require 'projectile)
+(require 'tramp-sh)
;;;; Variables
@@ -49,11 +49,19 @@
"The directory to store `dtache' database.")
(defvar dtache-db nil
"The connection to the `dtache' database.")
-(defconst dtache-program "dtach"
+(defvar dtache-program "dtach"
"The `dtach' program.")
-
-(defconst dtache-shell "bash"
+(defvar dtache-shell "bash"
"Shell to run the dtach command in.")
+(defvar dtache-metadata-annotators '((:git . dtache--session-git-branch))
+ "An alist of annotators for metadata.")
+(defvar dtache-max-command-length 95
+ "Maximum length of displayed command.")
+(defvar dtache-attach-alternate-function #'dtache-open-log
+ "Alternate function to use when attaching to inactive sessions.")
+(defvar dtache-shell-history-file nil
+ "File to store history.")
+
(defconst dtache-socket-ext ".socket"
"The file name extension for the socket for `dtache-program'.")
(defconst dtache-log-ext ".log"
@@ -64,15 +72,15 @@
"The file name extension for stderr.")
(defconst dtache-eof-message "\\[EOF - dtach terminating\\]\^M"
"Message printed when `dtach' finishes.")
-
-(defvar dtache-block-list '("^$" "^cd.*" "^mkdir.*" "^touch.*" "^alias.*")
- "A list of regexps that are blocked and should not be sent to `dtache'.")
-(defvar dtache-max-command-length 95
- "Maximum length of displayed command.")
+(defconst dtache-detached-message "\\[detached\\]\^M"
+ "Message printed when `dtach' finishes.")
+(defconst dtache-detach-character "\C-\\"
+ "Character used to detach from a session.")
;;;;; Private
-(defvar dtache--sessions nil "A list of the current sessions.")
+(defvar dtache--session-candidates nil "An alist of session candidates.")
+(defvar dtache--current-session nil "The current session.")
;;;; Data structures
@@ -80,32 +88,166 @@
(:conc-name dtache--session-))
(id nil :read-only t)
(command nil :read-only t)
- (directory nil :read-only t)
+ (working-directory nil :read-only t)
(creation-time nil :read-only t)
- (git nil :read-only t)
+ (session-directory nil :read-only t)
+ (metadata nil :read-only t)
+ (host nil :read-only t)
(duration nil)
(log-size nil)
(stderr-p nil)
(active nil))
-;;;; Interfaces
+;;;; Functions
+
+;;;;; Session
+
+(defun dtache-select-session ()
+ "Return selected session."
+ (let* ((candidates (dtache-session-candidates))
+ (candidate
+ (completing-read "Select session: "
+ (lambda (str pred action)
+ (pcase action
+ ('metadata '(metadata (category . dtache)
+ (cycle-sort-function .
identity)
+ (display-sort-function .
identity)))
+ (`(boundaries . ,_) nil)
+ ('nil (try-completion str candidates pred))
+ ('t (all-completions str candidates pred))
+ (_ (test-completion str candidates pred))))
+ nil t nil 'dtache-session-history)))
+ (dtache-decode-session candidate)))
+
+(defun dtache-session-file (session file)
+ "Return the path to SESSION's FILE."
+ (let ((file-name
+ (concat
+ (dtache--session-id session)
+ (pcase file
+ ('socket dtache-socket-ext)
+ ('log dtache-log-ext)
+ ('stdout dtache-stdout-ext)
+ ('stderr dtache-stderr-ext))))
+ (directory (concat
+ (file-remote-p default-directory)
+ (dtache--session-session-directory session))))
+ (expand-file-name file-name directory)))
+
+(defun dtache-update-sessions ()
+ "Update sessions in the database."
+ (thread-last (dtache--db-select-active-sessions (dtache--host))
+ (seq-remove (lambda (session)
+ (when (dtache--session-dead-p session)
+ (dtache--db-remove-session session)
+ t)))
+ (seq-map #'dtache--session-update)
+ (seq-map #'dtache--db-update-session)))
+
+(defun dtache-cleanup-sessions ()
+ "Remove dead sessions from the database."
+ (thread-last (dtache--db-select-host-sessions (dtache--host))
+ (seq-filter #'dtache--session-dead-p)
+ (seq-map #'dtache--db-remove-session)))
+
+(defun dtache-session-command (session)
+ "Return SESSION's command."
+ (dtache--session-command session))
+
+(defun dtache-session-candidates ()
+ "Return an alist of session candidates."
+ (dtache-update-sessions)
+ (let* ((sessions (nreverse
+ (dtache--db-select-host-sessions (dtache--host)))))
+ (setq dtache--session-candidates
+ (seq-map (lambda (session)
+ `(,(dtache-encode-session session) . ,session))
+ sessions))))
+
+;;;;; Database
+
+(defun dtache-db-initialize ()
+ "Initialize the `dtache' database."
+ (unless (file-exists-p dtache-db-directory)
+ (make-directory dtache-db-directory t))
+ (unless dtache-db
+ (setq dtache-db
+ (emacsql-sqlite
+ (expand-file-name "dtache.db" dtache-db-directory)))
+ (emacsql dtache-db
+ [:create-table
+ :if :not :exists dtache-sessions
+ ([(id text :primary-key) host active dtache-session])])))
+
+;;;;; Shell
+
+(defun dtache-override-shell-history (orig-fun &rest args)
+ "Override history to read `dtache-shell-history-file' in ORIG-FUN with ARGS.
+
+This function also makes sure that the HISTFILE is disabled for local shells."
+ (cl-letf (((getenv "HISTFILE") ""))
+ (advice-add 'comint-read-input-ring :around
#'dtache--shell-comint-read-input-ring-a)
+ (apply orig-fun args)))
+
+(defun dtache-save-shell-history ()
+ "Add hook to save history when killing `shell' buffer."
+ (add-hook 'kill-buffer-hook #'dtache--shell-save-history 0 t))
+
+;;;;; Other
+
+(defun dtache-setup ()
+ "Setup `dtache'."
+ (advice-add 'shell :around #'dtache-override-shell-history)
+ (add-hook 'shell-mode-hook #'dtache-save-shell-history))
+
+(defun dtache-dtach-command (session)
+ "Return a dtach command for SESSION."
+ (let* ((command (dtache-session-command session))
+ (directory (dtache--session-session-directory session))
+ (file-name (dtache--session-id session))
+ (stdout (concat directory file-name dtache-stdout-ext))
+ (stderr (concat directory file-name dtache-stderr-ext))
+ (log (concat directory file-name dtache-log-ext))
+ (socket (concat directory file-name dtache-socket-ext))
+ ;; Construct the command line
+ ;; { { echo stdout; echo stderr >&2; } >>(tee stdout ); } 2>>(tee
stderr) | tee log
+ (commandline (format "{ { %s; }%s }%s %s"
+ (format "%s" command)
+ (format " > >(tee %s );" stdout)
+ (format " 2> >(tee %s )" stderr)
+ (format " | tee %s" log))))
+ (format "%s -c %s -z %s -c %s" dtache-program socket dtache-shell
(shell-quote-argument commandline))))
+
+(defun dtache-metadata ()
+ "Return a property list with metadata."
+ (let ((metadata '()))
+ (seq-doseq (annotator dtache-metadata-annotators)
+ (setq metadata (plist-put metadata (car annotator) (funcall (cdr
annotator)))))
+ metadata))
-(cl-defgeneric dtache-attach (session)
- "A context aware function to attach to SESSION.")
+(defun dtache-encode-session (session)
+ "Encode SESSION as a string."
+ (let ((command
+ (dtache--session-truncate-command session))
+ (id
+ (dtache--session-short-id session)))
+ (concat
+ command
+ " "
+ (propertize id 'face 'font-lock-comment-face))))
-(cl-defmethod dtache-attach (session &context (major-mode shell-mode))
- "Attach to a dtache SESSION when MAJOR-MODE is `shell-mode'.
+(defun dtache-decode-session (candidate)
+ "Return the session that match CANDIDATE."
+ (cdr (assoc candidate dtache--session-candidates)))
-`comint-add-to-input-history' is temporarily disabled to avoid
-cluttering the comint-history with dtach commands."
- (unless (process-running-child-p (get-process (buffer-name)))
- (let* ((socket (dtache--session-file session 'socket))
- (input (concat dtache-program " -a " (shell-quote-argument
socket))))
- (goto-char (point-max))
- (insert input)
- (cl-letf (((symbol-function 'comint-add-to-input-history)
- (lambda (_) t)))
- (comint-send-input)))))
+(defun dtache-create-session-directory ()
+ "Create session directory if it doesn't exist."
+ (let ((directory
+ (concat
+ (file-remote-p default-directory)
+ dtache-session-directory)))
+ (unless (file-exists-p directory)
+ (make-directory directory t))))
;;;; Commands
@@ -116,32 +258,36 @@ cluttering the comint-history with dtach commands."
(list (dtache-select-session)))
(let ((buffer-name
(format "*dtache-compile-%s*"
- (dtache--session-short-id session))))
- (when (f-exists-p (dtache--session-file session 'log))
+ (dtache--session-short-id session)))
+ (file
+ (dtache-session-file session 'log)))
+ (when (file-exists-p file)
(with-current-buffer (get-buffer-create buffer-name)
(setq-local buffer-read-only nil)
(erase-buffer)
- (insert-file-contents (dtache--session-file session 'log))
- (setq-local default-directory (dtache--session-directory session))
+ (insert-file-contents file )
+ (setq-local default-directory
+ (dtache--session-working-directory session))
(compilation-mode))
(pop-to-buffer buffer-name))))
;;;###autoload
-(defun dtache-copy-session-content (session)
- "Copy content of SESSION."
+(defun dtache-copy-session-log (session)
+ "Copy SESSION's log."
(interactive
(list (dtache-select-session)))
- (dtache--file-content (dtache--session-file session 'log)))
+ (dtache--file-content
+ (dtache-session-file session 'log)))
;;;###autoload
-(defun dtache-copy-session (session)
- "Copy SESSION."
+(defun dtache-copy-session-command (session)
+ "Copy SESSION command."
(interactive
(list (dtache-select-session)))
(kill-new (dtache--session-command session)))
;;;###autoload
-(defun dtache-insert-session (session)
+(defun dtache-insert-session-command (session)
"Insert SESSION."
(interactive
(list (dtache-select-session)))
@@ -161,11 +307,12 @@ cluttering the comint-history with dtach commands."
"Send a TERM signal to SESSION."
(interactive
(list (dtache-select-session)))
- (if (not (dtache--session-active-p session))
- (message "Session is already inactive.")
- (let* ((default-directory (dtache--session-directory session))
- (process-group (prin1-to-string (dtache--session-process-group
session))))
- (shell-command (format "kill -- -%s" process-group)))))
+ (let* ((pids (flatten-list
+ (dtache--session-child-pids
+ (dtache--session-pid session)))))
+ (seq-doseq (pid pids)
+ (apply #'process-file
+ `("kill" nil nil nil ,pid)))))
;;;###autoload
(defun dtache-open-log (session)
@@ -188,265 +335,111 @@ cluttering the comint-history with dtach commands."
(list (dtache-select-session)))
(dtache--open-file session 'stderr))
-;;;###autoload
-(defun dtache-attach-to-session (session)
- "Attach to SESSION."
- (interactive
- (list (dtache-select-session)))
- (if (dtache--session-active-p session)
- (dtache-attach session)
- (dtache-open-log session)))
-
-;;;; Functions
-
-(defun dtache-setup ()
- "Setup `dtache'."
- ;; Safety first
- (unless (executable-find "dtach")
- (error "`dtache' requires program `dtach' to be installed"))
- (unless dtache-session-directory
- (error "`dtache-session-directory' must be configured"))
- (unless dtache-db-directory
- (error "`dtache-db-directory' must be configured"))
- ;; Setup
- (unless (file-exists-p dtache-session-directory)
- (make-directory dtache-session-directory t))
- (unless (file-exists-p dtache-db-directory)
- (make-directory dtache-db-directory t))
- (dtache-db-initialize))
-
-;;;;; Database
-
-(defun dtache-db-initialize ()
- "Initialize the `dtache' database."
- (setq dtache-db
- (emacsql-sqlite
- (expand-file-name "dtache.db" dtache-db-directory)))
- (emacsql dtache-db
- [:create-table
- :if :not :exists dtache-sessions
- ([(id text :primary-key) dtache-session])]))
-
-(defun dtache-db-reinitialize ()
- "Reinitialize the `dtache' database."
- (let ((db-alive
- (and (emacsql-sqlite-connection-p dtache-db)
- (emacsql-live-p dtache-db))))
- (when db-alive
- (emacsql-close dtache-db))
- (dtache-db-initialize)))
-
-;;;;; Sessions
-
-(defun dtache-select-session ()
- "Return selected session."
- (let* ((sessions (dtache--sessions))
- (selected
- (completing-read "Select session: "
- (lambda (str pred action)
- (pcase action
- ('metadata '(metadata (category . dtache)
- (cycle-sort-function .
identity)
- (display-sort-function .
identity)))
- (`(boundaries . ,_) nil)
- ('nil (try-completion str sessions pred))
- ('t (all-completions str sessions pred))
- (_ (test-completion str sessions pred))))
- nil t nil 'dtache-session-history)))
- (dtache-session-decode selected)))
-
-(defun dtache-update-sessions ()
- "Update sessions in the database."
- (let ((sessions (dtache--db-select-sessions)))
- (-some->> sessions
- (-filter #'dtache--session-active)
- (-map #'dtache-session--update)
- (-map #'dtache--db-update-session))))
-
-(defun dtache-cleanup-sessions ()
- "Remove dead sessions from the database."
- (let ((sessions (dtache--db-select-sessions)))
- (-some->> sessions
- (-filter #'dtache--session-dead-p)
- (-map #'dtache--db-remove-session))))
+;;;; Support functions
-(defun dtache-session-command (session)
- "Return a dtach command for SESSION."
- (let* ((command (dtache--session-command session))
- (stdout (dtache--session-file session 'stdout))
- (stderr (dtache--session-file session 'stderr))
- (stdout+stderr (dtache--session-file session 'log))
- (socket (dtache--session-file session 'socket))
- ;; Construct the command line
- ;; { { echo stdout; echo stderr >&2; } >>(tee stdout ); } 2>>(tee
stderr) | tee log
- (commandline (format "{ { %s; }%s }%s %s"
- (format "%s" command)
- (format " > >(tee %s );" stdout)
- (format " 2> >(tee %s )" stderr)
- (format " | tee %s" stdout+stderr))))
- (format "%s -c %s -z %s -c %s" dtache-program socket dtache-shell
(shell-quote-argument commandline))))
+;;;;; Session
-(defun dtache-create-session (command)
+(defun dtache--create-session (command)
"Create a `dtache' session from COMMAND."
(let ((session
(dtache--session-create :id (dtache--create-id command)
:command command
- :directory default-directory
+ :working-directory default-directory
:creation-time (time-to-seconds
(current-time))
- :git (dtache--session-git-info)
+ :session-directory (file-name-as-directory
dtache-session-directory)
+ :host (dtache--host)
+ :metadata (dtache-metadata)
:active t)))
(dtache--db-insert-session session)
session))
-;;;;; String representations
-
-(defun dtache-session-encode (session)
- "Encode SESSION as a string."
- (let ((command
- (dtache--session-truncate-command session))
- (hash
- (dtache--session-short-id session)))
- (s-concat
- command
- " "
- (propertize hash 'face 'font-lock-comment-face))))
-
-(defun dtache-session-decode (str)
- "Decode STR to a session."
- (cdr (assoc str dtache--sessions)))
-
-;;;; Support functions
-
-(defun dtache--command-string (session)
- "Return SESSION's command as a string."
- (let ((command (dtache--session-command session)))
- (if (< (length command) dtache-max-command-length)
- (s-pad-right dtache-max-command-length " " command)
- (s-concat
- (s-truncate (/ dtache-max-command-length 2) command)
- (s-right (/ dtache-max-command-length 2) command)))))
+(defun dtache--session-pid (session)
+ "Return SESSION's pid."
+ (let* ((socket (concat
+ (dtache--session-session-directory session)
+ (dtache--session-id session)
+ dtache-socket-ext))
+ (regexp (concat "dtach -c " socket))
+ (ps-args '("aux" "-w")))
+ (with-temp-buffer
+ (apply #'process-file `("ps" nil t nil ,@ps-args))
+ (buffer-substring-no-properties (point-min) (point-max))
+ (goto-char (point-min))
+ (search-forward-regexp regexp nil t)
+ (elt (split-string (thing-at-point 'line) " " t) 1))))
+
+(defun dtache--session-child-pids (pid)
+ "Return a list of pids for all child processes including PID."
+ (let ((pids `(,pid))
+ (child-processes
+ (split-string
+ (shell-command-to-string (format "pgrep -P %s" pid))
+ "\n" t)))
+ (seq-do (lambda (pid)
+ (push (dtache--session-child-pids pid) pids))
+ child-processes)
+ pids))
(defun dtache--session-truncate-command (session)
"Return a truncated string representation of SESSION's command."
(let ((command (dtache--session-command session))
(part-length (- dtache-max-command-length 3)))
(if (<= (length command) dtache-max-command-length)
- (s-pad-right dtache-max-command-length " " command)
- (s-concat
- (s-left (/ part-length 2) command)
+ (let ((padding-length (- dtache-max-command-length (length command))))
+ (concat command (make-string padding-length ?\s)))
+ (concat
+ (substring command 0 (/ part-length 2))
"..."
- (s-right (/ part-length 2) command)))))
+ (substring command (- (length command) (/ part-length 2)) (length
command))))))
-(defun dtache-session--update (session)
+(defun dtache--session-update (session)
"Update the `dtache' SESSION."
(setf (dtache--session-active session) (dtache--session-active-p session))
(setf (dtache--session-duration session) (dtache--duration session))
(setf (dtache--session-log-size session) (file-attribute-size
(file-attributes
- (dtache--session-file session
'log))))
+ (dtache-session-file session
'log))))
(setf (dtache--session-stderr-p session) (> (file-attribute-size
(file-attributes
- (dtache--session-file session
'stderr))) 0))
+ (dtache-session-file session
'stderr)))
+ 0))
session)
-(defun dtache--session-git-info ()
+(defun dtache--session-git-branch ()
"Return current git branch."
(let ((git-directory (locate-dominating-file "." ".git")))
(when git-directory
(let ((args '("name-rev" "--name-only" "HEAD")))
(with-temp-buffer
- (apply #'call-process `("git" nil t nil ,@args))
- (s-trim (buffer-string)))))))
-
-(defun dtache--file-content (file)
- "Copy FILE's content."
- (with-temp-buffer
- (insert-file-contents file)
- (kill-new (buffer-string))))
-
-(defun dtache--sessions ()
- "Return an alist of sessions."
- (dtache-update-sessions)
- (let ((sessions (nreverse (dtache--db-select-sessions))))
- (setq dtache--sessions
- (--map `(,(dtache-session-encode it) . ,it) sessions))))
-
-(defun dtache--duration (session)
- "Return the time duration of the SESSION.
-
-Modification time is not reliable whilst a session is active. Instead
-the current time is used."
- (if (dtache--session-active session)
- (- (time-to-seconds) (dtache--session-creation-time session))
- (- (time-to-seconds
- (file-attribute-modification-time
- (file-attributes
- (dtache--session-file session 'log))))
- (dtache--session-creation-time session))))
-
-(defun dtache--open-file (session file)
- "Oen SESSION's FILE."
- (let ((buffer-name (format "*dtache-%s-%s*" file
- (dtache--session-short-id session))))
- (when (f-exists-p (dtache--session-file session file))
- (with-current-buffer (get-buffer-create buffer-name)
- (erase-buffer)
- (insert-file-contents (dtache--session-file session file))
- (setq-local default-directory (dtache--session-directory session)))
- (pop-to-buffer buffer-name)
- (dtache-log-mode))))
-
-(defun dtache--create-id (command)
- "Return a hash identifier for COMMAND."
- (let ((current-time (current-time-string)))
- (secure-hash 'md5 (concat command current-time))))
-
-;;;;; Sessions
+ (apply #'process-file `("git" nil t nil ,@args))
+ (string-trim (buffer-string)))))))
(defun dtache--session-short-id (session)
"Return the short representation of the SESSION's id."
- (s-right 8 (dtache--session-id session)))
+ (let ((id (dtache--session-id session)))
+ (substring id (- (length id) 8) (length id))))
(defun dtache--session-active-p (session)
"Return t if SESSION is active."
- (f-exists-p (dtache--session-file session 'socket)))
+ (file-exists-p
+ (dtache-session-file session 'socket)))
(defun dtache--session-dead-p (session)
"Return t if SESSION is dead."
- (not (f-exists-p (dtache--session-file session 'log))))
-
-(defun dtache--session-process-group (session)
- "Return the process id for SESSION."
- (let* ((socket (f-filename (dtache--session-file session 'socket))))
- (-find (lambda (process)
- (let-alist (process-attributes process)
- (when (s-matches-p socket .args)
- .pgrp)))
- (list-system-processes))))
-
-(defun dtache--session-file (session file)
- "Return path to SESSION's FILE."
- (expand-file-name
- (concat (dtache--session-id session)
- (dtache--session-extension file))
- dtache-session-directory))
-
-(defun dtache--session-extension (file)
- "Return extensions of FILE."
- (pcase file
- ('socket dtache-socket-ext)
- ('log dtache-log-ext)
- ('stdout dtache-stdout-ext)
- ('stderr dtache-stderr-ext)))
+ (not
+ (file-exists-p
+ (dtache-session-file session 'log))))
;;;;; Database
(defun dtache--db-insert-session (session)
"Insert SESSION into the database."
- (let ((id (dtache--session-id session)))
+ (let ((id (dtache--session-id session))
+ (host (dtache--session-host session))
+ (active (dtache--session-active session)))
(emacsql dtache-db `[:insert
:into dtache-sessions
- :values ([,id ,session])])))
+ :values ([,id ,host ,active ,session])])))
(defun dtache--db-update-session (session)
"Update the database with SESSION."
@@ -454,7 +447,11 @@ the current time is used."
(emacsql dtache-db [:update dtache-sessions
:set (= dtache-session $s2)
:where (= id $s1)]
- id session)))
+ id session)
+ (emacsql dtache-db [:update dtache-sessions
+ :set (= active $s2)
+ :where (= id $s1)]
+ id (dtache--session-active session))))
(defun dtache--db-remove-session (session)
"Remove SESSION from the database."
@@ -472,15 +469,100 @@ the current time is used."
:where (= id $s1)]
id)))
-(defun dtache--db-select-sessions ()
- "Return all sessions from the database."
+(defun dtache--db-select-host-sessions (host)
+ "Return all HOST sessions from the database."
+ (let ((sessions
+ (emacsql dtache-db
+ [:select dtache-session
+ :from dtache-sessions
+ :where (= host $s1)]
+ host)))
+ (seq-map #'car sessions)))
+
+(defun dtache--db-select-active-sessions (host)
+ "Return all active HOST sessions from the database."
(let ((sessions
(emacsql dtache-db
[:select dtache-session
- :from dtache-sessions])))
- (-map #'car sessions)))
+ :from dtache-sessions
+ :where (= host $s1) :and (= active $s2)]
+ host t)))
+ (seq-map #'car sessions)))
+
+;;;;; Shell
+
+(defun dtache--shell-comint-read-input-ring-a (orig-fun &rest args)
+ "Set `comint-input-ring-file-name' before calling ORIG-FUN with ARGS."
+ (with-connection-local-variables
+ (let ((comint-input-ring-file-name
+ (concat
+ (file-remote-p default-directory)
+ dtache-shell-history-file)))
+ (apply orig-fun args)
+ (advice-remove 'comint-read-input-ring
#'dtache--shell-comint-read-input-ring-a))))
+
+(defun dtache--shell-save-history ()
+ "Save `shell' history."
+ (with-connection-local-variables
+ (let ((comint-input-ring-file-name
+ (concat
+ (file-remote-p default-directory)
+ dtache-shell-history-file)))
+ (comint-write-input-ring))))
+
+;;;;; Other
+
+(defun dtache--host ()
+ "Return name of host."
+ (if-let ((remote-host (file-remote-p default-directory))
+ (regexp (rx "/" (one-or-more alpha) ":" (group (regexp ".*")) ":")))
+ (progn
+ (string-match regexp remote-host)
+ (match-string 1 remote-host))
+ "localhost"))
+
+(defun dtache--file-content (file)
+ "Copy FILE's content."
+ (with-temp-buffer
+ (insert-file-contents file)
+ (kill-new (buffer-string))))
+
+(defun dtache--duration (session)
+ "Return the time duration of the SESSION.
+
+Modification time is not reliable whilst a session is active. Instead
+the current time is used."
+ ;; TODO: This function might need to take into account that there
+ ;; might be a time offset between two computers
+ (if (dtache--session-active session)
+ (- (time-to-seconds) (dtache--session-creation-time session))
+ (- (time-to-seconds
+ (file-attribute-modification-time
+ (file-attributes
+ (dtache-session-file session 'log))))
+ (dtache--session-creation-time session))))
+
+(defun dtache--open-file (session file)
+ "Oen SESSION's FILE."
+ (let* ((buffer-name
+ (format "*dtache-%s-%s*" file
+ (dtache--session-short-id session)))
+ (file-path
+ (dtache-session-file session file)))
+ (when (file-exists-p file-path)
+ (with-current-buffer (get-buffer-create buffer-name)
+ (erase-buffer)
+ (insert-file-contents file-path)
+ (setq-local default-directory (dtache--session-working-directory
session)))
+ (pop-to-buffer buffer-name)
+ (dtache-log-mode))))
+
+(defun dtache--create-id (command)
+ "Return a hash identifier for COMMAND."
+ (let ((current-time (current-time-string)))
+ (secure-hash 'md5 (concat command current-time))))
-;;;; Major modes
+;;;; Major mode
(defvar dtache-log-mode-map
(let ((map (make-sparse-keymap)))
diff --git a/dtache-embark.el b/embark-dtache.el
similarity index 72%
rename from dtache-embark.el
rename to embark-dtache.el
index 6cc8968082..71dcde4adc 100644
--- a/dtache-embark.el
+++ b/embark-dtache.el
@@ -1,4 +1,4 @@
-;;; dtache-embark.el --- Embark for dtache -*- lexical-binding: t -*-
+;;; embark-dtache.el --- Dtache Embark integration -*- lexical-binding: t -*-
;; Copyright (C) 2020-2021 Niklas Eklund
@@ -25,7 +25,7 @@
;;; Commentary:
-;; This package provides an embark keymap for dtache.
+;; This package provides `embark' actions to operate on `dtache' sessions.
;;; Code:
@@ -36,21 +36,20 @@
;;;; Keymap
-(embark-define-keymap dtache-embark-map
+(embark-define-keymap embark-dtache-map
"Keymap for Embark dtache actions."
("l" dtache-open-log)
("e" dtache-open-stderr)
("o" dtache-open-stdout)
- ("i" dtache-insert-session)
- ("w" dtache-copy-session)
- ("W" dtache-copy-session-content)
+ ("i" dtache-insert-session-command)
+ ("w" dtache-copy-session-command)
+ ("W" dtache-copy-session-log)
("c" dtache-compile-session)
("d" dtache-remove-session)
- ("k" dtache-kill-session)
- ("s" dtache-consult-search-session))
+ ("k" dtache-kill-session))
-(add-to-list 'embark-keymap-alist '(dtache . dtache-embark-map))
+(add-to-list 'embark-keymap-alist '(dtache . embark-dtache-map))
-(provide 'dtache-embark)
+(provide 'embark-dtache)
-;;; dtache-embark.el ends here
+;;; embark-dtache.el ends here
diff --git a/guix.scm b/guix.scm
new file mode 100644
index 0000000000..322a8f2b72
--- /dev/null
+++ b/guix.scm
@@ -0,0 +1,59 @@
+;;; guix.scm -- Guix package definition
+
+(use-modules
+ (guix packages)
+ (guix git-download)
+ (guix gexp)
+ (guix build-system gnu)
+ ((guix licenses) #:prefix license:)
+ (guix build-system emacs)
+ (gnu packages emacs-xyz)
+ (gnu packages screen)
+ (ice-9 popen)
+ (ice-9 rdelim))
+
+(define %source-dir (dirname (current-filename)))
+
+(define %git-commit
+ (read-string (open-pipe "git show HEAD | head -1 | cut -d ' ' -f2"
OPEN_READ)))
+
+(define-public emacs-dtache
+ (let ((branch "remote")
+ (commit "220f93dfa710474b4f9c9db0349a6082374f80c0")
+ (revision "0"))
+ (package
+ (name "emacs-dtache")
+ (version (git-version "0.0" revision commit))
+ (source
+ (origin
+ (method git-fetch)
+ (uri (git-reference
+ (url "https://gitlab.com/niklaseklund/dtache";)
+ (commit commit)))
+ (sha256
+ (base32
+ "0yvkygdqghrp8xn7nfgfq3x5y913r6kasqndxy3fr2dqpxxb941a"))
+ (file-name (git-file-name name version))))
+ (build-system emacs-build-system)
+ (propagated-inputs
+ `(("emacs-emacsql-sqlite3" ,emacs-emacsql-sqlite3)
+ ("emacs-embark" ,emacs-embark)
+ ("emacs-marginalia" ,emacs-marginalia)))
+ (native-inputs
+ `(("emacs-ert-runner" ,emacs-ert-runner)))
+ (inputs `(("dtach" ,dtach)))
+ (arguments
+ `(#:tests? #t
+ #:test-command '("ert-runner")))
+ (home-page "https://gitlab.com/niklaseklund/dtache";)
+ (synopsis "Dtach Emacs")
+ (description "Dtache allows a program to be seamlessly executed
+in an environment that is isolated from Emacs.")
+ (license license:gpl3+))))
+
+(package
+ (inherit emacs-dtache)
+ (name "emacs-dtache-git")
+ (version (git-version (package-version emacs-dtache) "HEAD" %git-commit))
+ (source (local-file %source-dir
+ #:recursive? #t)))
diff --git a/dtache-marginalia.el b/marginalia-dtache.el
similarity index 58%
rename from dtache-marginalia.el
rename to marginalia-dtache.el
index 42645a7e85..612d3af8e7 100644
--- a/dtache-marginalia.el
+++ b/marginalia-dtache.el
@@ -1,4 +1,4 @@
-;;; dtache-marginalia.el --- Marginalia for dtache -*- lexical-binding: t -*-
+;;; marginalia-dtache.el --- Dtache Marginalia integration -*-
lexical-binding: t -*-
;; Copyright (C) 2020-2021 Niklas Eklund
@@ -25,7 +25,7 @@
;;; Commentary:
-;; This package provides a marginalia annotator for dtache.
+;; This package provides annotated `dtache' sessions with `marginalia'.
;;; Code:
@@ -36,53 +36,58 @@
;;;; Variables
-(defvar dtache-marginalia-git-branch-length 30)
-(defvar dtache-marginalia-duration-length 10)
-(defvar dtache-marginalia-size-length 8)
-(defvar dtache-marginalia-date-length 12)
+(defvar marginalia-dtache-git-branch-length 30)
+(defvar marginalia-dtache-duration-length 10)
+(defvar marginalia-dtache-size-length 8)
+(defvar marginalia-dtache-date-length 12)
;;;; Faces
-(defface dtache-marginalia-git
+(defgroup marginalia-dtache-faces nil
+ "Faces used by `marginalia-mode'."
+ :group 'marginalia
+ :group 'faces)
+
+(defface marginalia-dtache-git
'((t :inherit marginalia-char))
"Face used to highlight git information in `marginalia-mode'.")
-(defface dtache-marginalia-error
+(defface marginalia-dtache-error
'((t :inherit error))
"Face used to highlight error in `marginalia-mode'.")
-(defface dtache-marginalia-active
+(defface marginalia-dtache-active
'((t :inherit marginalia-file-owner))
"Face used to highlight active in `marginalia-mode'.")
-(defface dtache-marginalia-duration
+(defface marginalia-dtache-duration
'((t :inherit marginalia-date))
"Face used to highlight duration in `marginalia-mode'.")
-(defface dtache-marginalia-size
+(defface marginalia-dtache-size
'((t :inherit marginalia-size))
"Face used to highlight size in `marginalia-mode'.")
-(defface dtache-marginalia-creation
+(defface marginalia-dtache-creation
'((t :inherit marginalia-date))
"Face used to highlight date in `marginalia-mode'.")
;;;; Functions
-(defun dtache-marginalia-annotate (candidate)
+(defun marginalia-dtache-annotate (candidate)
"Annotate dtache CANDIDATE."
- (let* ((session (dtache-session-decode candidate)))
+ (let* ((session (dtache-decode-session candidate)))
(marginalia--fields
- ((dtache-marginalia--active session) :width 3 :face
'dtache-marginalia-active)
- ((dtache-marginalia--stderr-p session) :width 3 :face
'dtache-marginalia-error)
- ((dtache-marginalia--git-branch session) :truncate
dtache-marginalia-git-branch-length :face 'dtache-marginalia-git)
- ((dtache-marginalia--duration session) :truncate
dtache-marginalia-duration-length :face 'dtache-marginalia-duration)
- ((dtache-marginalia--size session) :truncate
dtache-marginalia-size-length :face 'dtache-marginalia-size)
- ((dtache-marginalia--creation session) :truncate
dtache-marginalia-date-length :face 'dtache-marginalia-date))))
+ ((marginalia-dtache--active session) :width 3 :face
'marginalia-dtache-active)
+ ((marginalia-dtache--stderr-p session) :width 3 :face
'marginalia-dtache-error)
+ ((marginalia-dtache--git-branch session) :truncate
marginalia-dtache-git-branch-length :face 'marginalia-dtache-git)
+ ((marginalia-dtache--duration session) :truncate
marginalia-dtache-duration-length :face 'marginalia-dtache-duration)
+ ((marginalia-dtache--size session) :truncate
marginalia-dtache-size-length :face 'marginalia-dtache-size)
+ ((marginalia-dtache--creation session) :truncate
marginalia-dtache-date-length :face 'marginalia-dtache-date))))
;;;; Support functions
-(defun dtache-marginalia--duration (session)
+(defun marginalia-dtache--duration (session)
"Return SESSION's duration time."
(let* ((time (round (dtache--session-duration session)))
(hours (/ time 3600))
@@ -92,33 +97,33 @@
((> time 60) (format "%sm %ss" minutes seconds))
(t (format "%ss" seconds)))))
-(defun dtache-marginalia--creation (session)
+(defun marginalia-dtache--creation (session)
"Return SESSION's creation time."
(format-time-string
"%b %d %H:%M"
(dtache--session-creation-time session)))
-(defun dtache-marginalia--size (session)
+(defun marginalia-dtache--size (session)
"Return the size of SESSION's log."
(file-size-human-readable
(dtache--session-log-size session)))
-(defun dtache-marginalia--git-branch (session)
+(defun marginalia-dtache--git-branch (session)
"Return the git branch for SESSION."
- (dtache--session-git session))
+ (plist-get (dtache--session-metadata session) :git))
-(defun dtache-marginalia--active (session)
+(defun marginalia-dtache--active (session)
"Return string if SESSION is active."
(if (dtache--session-active session)
"*"
""))
-(defun dtache-marginalia--stderr-p (session)
+(defun marginalia-dtache--stderr-p (session)
"Return string if SESSION has errors."
(if (dtache--session-stderr-p session)
"!"
""))
-(provide 'dtache-marginalia)
+(provide 'marginalia-dtache)
-;;; dtache-marginalia.el ends here
+;;; marginalia-dtache.el ends here
diff --git a/test/dtache-shell-test.el b/test/dtache-shell-test.el
index 91e2b70998..f953cce8b6 100644
--- a/test/dtache-shell-test.el
+++ b/test/dtache-shell-test.el
@@ -4,7 +4,7 @@
;; Author: Niklas Eklund <niklas.ekl...@posteo.net>
;; Url: https://gitlab.com/niklaseklund/dtache
-;; Package-requires: ((emacs "26.1"))
+;; Package-Requires: ((emacs "27.1"))
;; Version: 0.1
;; This program is free software; you can redistribute it and/or modify
@@ -22,7 +22,7 @@
;;; Commentary:
-;; Tests for dtache-shell
+;; Tests for `dtache-shell'.
;;; Code:
@@ -35,7 +35,13 @@
(let ((str "
[EOF - dtach terminating]
user@machine "))
- (should (string= "
\nuser@machine " (dtache-shell--filter-dtach-eof str)))))
+ (should (string= "
\nuser@machine " (dtache-shell-filter-dtach-eof str)))))
+
+(ert-deftest dtache-shell-test-filter-detached ()
+ (let ((str "
+[detached]
+user@machine "))
+ (should (string= "
\nuser@machine " (dtache-shell-filter-dtach-detached str)))))
(provide 'dtache-shell-test)
diff --git a/test/dtache-test.el b/test/dtache-test.el
index 2e0355daac..e48e11ad3e 100644
--- a/test/dtache-test.el
+++ b/test/dtache-test.el
@@ -4,7 +4,7 @@
;; Author: Niklas Eklund <niklas.ekl...@posteo.net>
;; Url: https://gitlab.com/niklaseklund/dtache
-;; Package-requires: ((emacs "26.1"))
+;; Package-Requires: ((emacs "27.1"))
;; Version: 0.1
;; This program is free software; you can redistribute it and/or modify
@@ -22,14 +22,91 @@
;;; Commentary:
-;; Tests for dtache
+;; Tests for `dtache'.
;;; Code:
+;;;; Requirements
+
(require 'ert)
(require 'dtache)
-;;; Tests
+;;;; Support
+
+(defmacro dtache-test--with-temp-database (&rest body)
+ "Initialize a dtache database and evaluate BODY."
+ `(let* ((temp-directory (make-temp-file "dtache" t))
+ (dtache-db-directory (expand-file-name "db" temp-directory))
+ (dtache-session-directory (expand-file-name "sessions"
temp-directory))
+ (dtache-db))
+ (unwind-protect
+ (progn
+ (dtache-db-initialize)
+ (dtache-create-session-directory)
+ ,@body)
+ (delete-directory temp-directory t))))
+
+(cl-defun dtache-test--create-session (&key command host)
+ "Create session with COMMAND running on HOST."
+ (cl-letf* (((symbol-function #'dtache--host) (lambda () host))
+ ((symbol-function #'dtache-metadata) (lambda () nil))
+ (session (dtache--create-session command)))
+ (dtache-test--change-session-state session 'activate)
+ session))
+
+(defun dtache-test--change-session-state (session state)
+ "Set STATE of SESSION."
+ (pcase state
+ ('activate
+ (dolist (type `(socket log stderr))
+ (with-temp-file (dtache-session-file session type))))
+ ('deactivate
+ (delete-file (dtache-session-file session 'socket)))
+ ('kill
+ (delete-file (dtache-session-file session 'socket))
+ (delete-file (dtache-session-file session 'log))
+ (delete-file (dtache-session-file session 'stderr)))))
+
+;;;; Tests
+
+(ert-deftest dtache-test-dtach-command ()
+ (let* ((dtache-shell "zsh")
+ (dtache-program "/usr/bin/dtach")
+ (actual
+ (dtache-dtach-command
+ (dtache--session-create :id "12345" :session-directory
"/tmp/dtache/")))
+ (expected "^/usr/bin/dtach -c /tmp/dtache/12345.socket -z zsh -c .*"))
+ (should (string-match-p expected actual))))
+
+(ert-deftest dtache-test-metadata ()
+ ;; No annotators
+ (let ((dtache-metadata-annotators '()))
+ (should (not (dtache-metadata))))
+
+ ;; Two annotatos
+ (let ((dtache-metadata-annotators
+ '((:git-branch . (lambda () "foo"))
+ (:username . (lambda () "bar"))))
+ (expected '(:git-branch "foo" :username "bar")))
+ (should (equal (dtache-metadata) expected))))
+
+(ert-deftest dtache-test-session-file ()
+ ;; Local files
+ (cl-letf* (((symbol-function #'expand-file-name) (lambda (file directory)
(concat directory file)))
+ (session (dtache--session-create :id "12345" :session-directory
"/home/user/tmp/")))
+ (should (string= "/home/user/tmp/12345.log" (dtache-session-file session
'log)))
+ (should (string= "/home/user/tmp/12345.stderr" (dtache-session-file
session 'stderr)))
+ (should (string= "/home/user/tmp/12345.stdout" (dtache-session-file
session 'stdout)))
+ (should (string= "/home/user/tmp/12345.socket" (dtache-session-file
session 'socket))))
+
+ ;; Remote files
+ (cl-letf* (((symbol-function #'expand-file-name) (lambda (file directory)
(concat directory file)))
+ ((symbol-function #'file-remote-p) (lambda (_directory)
"/ssh:foo:"))
+ (session (dtache--session-create :id "12345" :session-directory
"/home/user/tmp/")))
+ (should (string= "/ssh:foo:/home/user/tmp/12345.log" (dtache-session-file
session 'log)))
+ (should (string= "/ssh:foo:/home/user/tmp/12345.stderr"
(dtache-session-file session 'stderr)))
+ (should (string= "/ssh:foo:/home/user/tmp/12345.stdout"
(dtache-session-file session 'stdout)))
+ (should (string= "/ssh:foo:/home/user/tmp/12345.socket"
(dtache-session-file session 'socket)))))
(ert-deftest dtache-test-session-short-id ()
(let ((session (dtache--session-create :id "abcdefg12345678")))
@@ -50,7 +127,129 @@
(dtache--session-create :command "abcdefghijk"
:id "-------12345678"))
(dtache-max-command-length 8))
- (should (string= "ab...jk 12345678" (dtache-session-encode session)))))
+ (should (string= "ab...jk 12345678" (dtache-encode-session session)))))
+
+(ert-deftest dtache-test-host ()
+ (should (string= "localhost" (dtache--host)))
+ (let ((default-directory "/ssh:remotehost:/home/user/git"))
+ (should (string= "remotehost" (dtache--host)))))
+
+(ert-deftest dtache-test-session-active-p ()
+ (dtache-test--with-temp-database
+ (let ((session (dtache-test--create-session :command "foo" :host
"localhost")))
+ (should (dtache--session-active-p session))
+ (dtache-test--change-session-state session 'deactivate)
+ (should (not (dtache--session-active-p session))))))
+
+(ert-deftest dtache-test-session-dead-p ()
+ (dtache-test--with-temp-database
+ (let ((session (dtache-test--create-session :command "foo" :host
"localhost")))
+ (should (not (dtache--session-dead-p session)))
+ (dtache-test--change-session-state session 'deactivate)
+ (should (not (dtache--session-dead-p session)))
+ (dtache-test--change-session-state session 'kill)
+ (should (dtache--session-dead-p session)))))
+
+(ert-deftest dtache-test-session-decode ()
+ (dtache-test--with-temp-database
+ (dtache-test--create-session :command "foo" :host "localhost")
+ (dtache-session-candidates)
+ (should
+ (equal (elt (dtache--db-select-host-sessions "localhost") 0)
+ (dtache-decode-session
+ (car (elt dtache--session-candidates 0)))))))
+
+(ert-deftest dtache-test-session-candidates ()
+ (dtache-test--with-temp-database
+ (dtache-test--create-session :command "foo" :host "localhost")
+ (dtache-test--create-session :command "bar" :host "localhost")
+ (should
+ (seq-set-equal-p
+ (thread-last (dtache-session-candidates)
+ (seq-map #'cdr))
+ (seq-reverse
+ (dtache--db-select-host-sessions "localhost"))))))
+
+(ert-deftest dtache-test-update-sessions ()
+ (dtache-test--with-temp-database
+ (cl-letf* ((session1 (dtache-test--create-session :command "foo" :host
"localhost"))
+ (session2 (dtache-test--create-session :command "bar" :host
"localhost"))
+ (session3 (dtache-test--create-session :command "baz" :host
"remotehost"))
+ (host "localhost")
+ ((symbol-function #'dtache--host) (lambda () host)))
+ ;; Add three sessions two matching host which will be
+ ;; updated. One of them is dead and should be removed
+ (dtache-test--change-session-state session2 'kill)
+ (dtache-test--change-session-state session3 'deactivate)
+ (dtache-update-sessions)
+ (let ((db-sessions (dtache--db-select-host-sessions host)))
+ (should (= (length db-sessions) 1))
+ (should (string= (dtache--session-id (elt db-sessions 0))
(dtache--session-id session1)))
+ (should (not (equal (elt db-sessions 0) session1)))))))
+
+(ert-deftest dtache-test-cleanup-sessions ()
+ (dtache-test--with-temp-database
+ (cl-letf* ((session1 (dtache-test--create-session :command "foo" :host
"remotehost"))
+ (session2 (dtache-test--create-session :command "bar" :host
"localhost"))
+ (session3 (dtache-test--create-session :command "baz" :host
"localhost"))
+ (host "localhost")
+ ((symbol-function #'dtache--host) (lambda () host)))
+ ;; One active, one dead, one active
+ (dtache-test--change-session-state session1 'deactivate)
+ (dtache-test--change-session-state session2 'kill)
+ (dtache-cleanup-sessions)
+ (should (seq-set-equal-p
+ (dtache--db-select-host-sessions host)
+ `(,session3))))))
+
+;;;;; Database
+
+(ert-deftest dtache-test-db-initialize ()
+ (dtache-test--with-temp-database
+ (should (emacsql-live-p dtache-db))))
+
+(ert-deftest dtache-test-db-insert-session ()
+ (dtache-test--with-temp-database
+ (let* ((session (dtache-test--create-session :command "foo" :host
"localhost"))
+ (id (dtache--session-id session)))
+ (should (equal (dtache--db-select-session id) session)))))
+
+(ert-deftest dtache-test-db-remove-session ()
+ (dtache-test--with-temp-database
+ (let* ((host "localhost")
+ (session1 (dtache-test--create-session :command "foo" :host host))
+ (session2 (dtache-test--create-session :command "bar" :host host)))
+ (should (seq-set-equal-p `(,session1 ,session2)
(dtache--db-select-host-sessions host)))
+ (dtache--db-remove-session session1)
+ (should (seq-set-equal-p `(,session2) (dtache--db-select-host-sessions
host))))))
+
+(ert-deftest dtache-test-db-update-session ()
+ (dtache-test--with-temp-database
+ (let* ((session (dtache-test--create-session :command "foo" :host
"localhost"))
+ (id (dtache--session-id session)))
+ (setf (dtache--session-active session) nil)
+ (should (not (equal session (dtache--db-select-session id))))
+ (dtache--db-update-session session)
+ (should (equal session (dtache--db-select-session id))))))
+
+(ert-deftest dtache-test-db-select-host-sessions ()
+ (dtache-test--with-temp-database
+ (let* ((session1 (dtache-test--create-session :command "foo" :host
"localhost"))
+ (session2 (dtache-test--create-session :command "bar" :host
"remotehost"))
+ (session3 (dtache-test--create-session :command "baz" :host
"localhost")))
+ (should (seq-set-equal-p `(,session2) (dtache--db-select-host-sessions
"remotehost")))
+ (should (seq-set-equal-p `(,session1 ,session3)
(dtache--db-select-host-sessions "localhost"))))))
+
+(ert-deftest dtache-test-db-select-active-sessions ()
+ (dtache-test--with-temp-database
+ (let* ((session1 (dtache-test--create-session :command "foo" :host
"localhost"))
+ (session2 (dtache-test--create-session :command "bar" :host
"remotehost"))
+ (session3 (dtache-test--create-session :command "baz" :host
"localhost")))
+ (dtache-test--change-session-state session1 'deactivate)
+ (dtache-update-sessions)
+ (let ((sessions (dtache--db-select-active-sessions "localhost")))
+ (should (= (length sessions) 1))
+ (should (string= (dtache--session-id (elt sessions 0))
(dtache--session-id session3)))))))
(provide 'dtache-test)
diff --git a/test/dtache-marginalia-test.el b/test/marginalia-dtache-test.el
similarity index 51%
rename from test/dtache-marginalia-test.el
rename to test/marginalia-dtache-test.el
index 0202fe1c92..913f087ec7 100644
--- a/test/dtache-marginalia-test.el
+++ b/test/marginalia-dtache-test.el
@@ -1,10 +1,10 @@
-;;; dtache-marginalia-test.el --- Tests for dtache-marginalia.el -*-
lexical-binding: t; -*-
+;;; marginalia-dtache-test.el --- Tests for marginalia-dtache.el -*-
lexical-binding: t; -*-
;; Copyright (C) 2020-2021 Niklas Eklund
;; Author: Niklas Eklund <niklas.ekl...@posteo.net>
;; Url: https://gitlab.com/niklaseklund/dtache
-;; Package-requires: ((emacs "26.1"))
+;; Package-Requires: ((emacs "27.1"))
;; Version: 0.1
;; This program is free software; you can redistribute it and/or modify
@@ -22,40 +22,40 @@
;;; Commentary:
-;; Tests for dtache-marginalia
+;; Tests for `marginalia-dtache'.
;;; Code:
(require 'ert)
-(require 'dtache-marginalia)
+(require 'marginalia-dtache)
-(ert-deftest dtache-marginalia-test-duration ()
- (should (string= "1s" (dtache-marginalia--duration (dtache--session-create
:duration 1))))
- (should (string= "1m 1s" (dtache-marginalia--duration
(dtache--session-create :duration 61))))
- (should (string= "1h 1m 1s" (dtache-marginalia--duration
(dtache--session-create :duration 3661)))))
+(ert-deftest marginalia-dtache-test-duration ()
+ (should (string= "1s" (marginalia-dtache--duration (dtache--session-create
:duration 1))))
+ (should (string= "1m 1s" (marginalia-dtache--duration
(dtache--session-create :duration 61))))
+ (should (string= "1h 1m 1s" (marginalia-dtache--duration
(dtache--session-create :duration 3661)))))
-(ert-deftest dtache-marginalia-test-creation ()
+(ert-deftest marginalia-dtache-test-creation ()
;; Make sure to set the TIMEZONE before executing the test to avoid
;; differences between machines
(cl-letf (((getenv "TZ") "UTC0"))
- (should (string= "May 08 08:49" (dtache-marginalia--creation
(dtache--session-create :creation-time 1620463748.7636228))))))
+ (should (string= "May 08 08:49" (marginalia-dtache--creation
(dtache--session-create :creation-time 1620463748.7636228))))))
-(ert-deftest dtache-marginalia-test-size ()
- (should (string= "100" (dtache-marginalia--size (dtache--session-create
:log-size 100))))
- (should (string= "1k" (dtache-marginalia--size (dtache--session-create
:log-size 1024)))))
+(ert-deftest marginalia-dtache-test-size ()
+ (should (string= "100" (marginalia-dtache--size (dtache--session-create
:log-size 100))))
+ (should (string= "1k" (marginalia-dtache--size (dtache--session-create
:log-size 1024)))))
-(ert-deftest dtache-marginalia-git ()
- (should (string= "foo" (dtache-marginalia--git-branch
(dtache--session-create :git "foo"))))
- (should (not (dtache-marginalia--git-branch (dtache--session-create)))))
+(ert-deftest marginalia-dtache-git ()
+ (should (string= "foo" (marginalia-dtache--git-branch
(dtache--session-create :metadata '(:git "foo")))))
+ (should (not (marginalia-dtache--git-branch (dtache--session-create)))))
-(ert-deftest dtache-marginalia-active ()
- (should (string= "*" (dtache-marginalia--active (dtache--session-create
:active t))))
- (should (string= "" (dtache-marginalia--active (dtache--session-create
:active nil)))))
+(ert-deftest marginalia-dtache-active ()
+ (should (string= "*" (marginalia-dtache--active (dtache--session-create
:active t))))
+ (should (string= "" (marginalia-dtache--active (dtache--session-create
:active nil)))))
-(ert-deftest dtache-marginalia-stderr-p ()
- (should (string= "!" (dtache-marginalia--stderr-p (dtache--session-create
:stderr-p t))))
- (should (string= "" (dtache-marginalia--stderr-p (dtache--session-create
:stderr-p nil)))))
+(ert-deftest marginalia-dtache-stderr-p ()
+ (should (string= "!" (marginalia-dtache--stderr-p (dtache--session-create
:stderr-p t))))
+ (should (string= "" (marginalia-dtache--stderr-p (dtache--session-create
:stderr-p nil)))))
-(provide 'dtache-marginalia-test)
+(provide 'marginalia-dtache-test)
-;;; dtache-marginalia-test.el ends here
+;;; marginalia-dtache-test.el ends here
