emacs-elpa-diffs
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[elpa] externals/dtache bcbc2d8b4d 003/158: Merge with development branc


From: ELPA Syncer
Subject: [elpa] externals/dtache bcbc2d8b4d 003/158: Merge with development branch
Date: Wed, 19 Jan 2022 18:57:39 -0500 (EST)

branch: externals/dtache
commit bcbc2d8b4dd071feeb86cdfb278f0d88a3679165
Author: Niklas Eklund <niklas.eklund@posteo.net>
Commit: Niklas Eklund <niklas.eklund@posteo.net>

    Merge with development branch
---
 LICENSE                        |   6 +-
 README.org                     |  86 +++++++
 dtache-embark.el               |  56 +++++
 dtache-marginalia.el           | 124 +++++++++++
 dtache-shell.el                | 136 +++++++++++
 dtache.el                      | 496 +++++++++++++++++++++++++++++++++++++++++
 notes.org                      |  24 ++
 test/dtache-marginalia-test.el |  61 +++++
 test/dtache-shell-test.el      |  42 ++++
 test/dtache-test.el            |  57 +++++
 10 files changed, 1085 insertions(+), 3 deletions(-)

diff --git a/LICENSE b/LICENSE
index b2d71a0d04..fb021035fd 100644
--- a/LICENSE
+++ b/LICENSE
@@ -631,8 +631,8 @@ to attach them to the start of each source file to most 
effectively
 state the exclusion of warranty; and each file should have at least
 the "copyright" line and a pointer to where the full notice is found.
 
-    detached
-    Copyright (C) 2020  Niklas Carlsson
+    dtache
+    Copyright (C) 2020  Niklas Eklund
 
     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
@@ -652,7 +652,7 @@ Also add information on how to contact you by electronic 
and paper mail.
   If the program does terminal interaction, make it output a short
 notice like this when it starts in an interactive mode:
 
-    detached  Copyright (C) 2020  Niklas Carlsson
+    dtache  Copyright (C) 2020  Niklas Eklund
     This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
     This is free software, and you are welcome to redistribute it
     under certain conditions; type `show c' for details.
diff --git a/README.org b/README.org
index e69de29bb2..6d670ed9bc 100644
--- a/README.org
+++ b/README.org
@@ -0,0 +1,86 @@
+* About
+
+The ~dtache~ package brings detachable commands to Emacs. Currently
+it is mainly boosting ~M-x shell~ through the ~dtache-shell.el~
+package. The ~dtache.el~ is the backend that provides a mean to create
+detachable sessions, and manages them through a database.
+
+** Background
+
+The package provides the following:
+- allows shell commands to run detached from Emacs
+- access to metadata as well as logs from the sessions
+  
+** Configuration
+
+Configure the ~dtache~ package.
+
+#+begin_src elisp
+  (use-package dtache
+    :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))
+#+end_src
+
+Configure the ~dtache-shell~ package. The ~dtache-shell-enable~ will
+activate the dtache-shell minor mode in shell buffers.
+
+#+begin_src elisp
+  (use-package dtache-shell
+    :hook (after-init . dtache-shell-enable))
+#+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.
+
+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)
+#+end_src
+
+** Optional
+
+If you are a user of ~marginalia~ and ~embark~ you might also be
+interested in adding the following to enrich the
+~dtache-attach-to-session~ command.
+
+#+begin_src elisp
+  (use-package dtache-marginalia
+    :after (dtache marginalia)
+    :config
+    (add-to-list 'marginalia-annotators-heavy '(dtache . 
dtache-marginalia-annotate)))
+
+  (use-package dtache-embark
+    :after (dtache embark))
+#+end_src
+
+** Commands
+
+The following is a list of commands that can be run on ~dtache~
+sessions.
+
+| 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-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      |
+
+* Recognition
+
+The inspiration for the package comes from 
[[https://github.com/Ambrevar/dotfiles/blob/master/.emacs.d/lisp/package-eshell-detach.el][ambrevar's
+package-eshell-detach]].
diff --git a/dtache-embark.el b/dtache-embark.el
new file mode 100644
index 0000000000..6cc8968082
--- /dev/null
+++ b/dtache-embark.el
@@ -0,0 +1,56 @@
+;;; dtache-embark.el --- Embark for dtache -*- lexical-binding: t -*-
+
+;; Copyright (C) 2020-2021 Niklas Eklund
+
+;; Author: Niklas Eklund <niklas.eklund@posteo.net>
+;; URL: https://www.gitlab.com/niklaseklund/dtache.git
+;; Version: 0.1
+;; Package-Requires: ((emacs "26.1"))
+;; Keywords: convenience processes
+
+;; This file is not part of GNU Emacs.
+
+;; 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.
+
+;; 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.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This package provides an embark keymap for dtache.
+
+;;; Code:
+
+;;;; Requirements
+
+(require 'dtache)
+(require 'embark)
+
+;;;; Keymap
+
+(embark-define-keymap dtache-embark-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)
+  ("c" dtache-compile-session)
+  ("d" dtache-remove-session)
+  ("k" dtache-kill-session)
+  ("s" dtache-consult-search-session))
+
+(add-to-list 'embark-keymap-alist '(dtache . dtache-embark-map))
+
+(provide 'dtache-embark)
+
+;;; dtache-embark.el ends here
diff --git a/dtache-marginalia.el b/dtache-marginalia.el
new file mode 100644
index 0000000000..42645a7e85
--- /dev/null
+++ b/dtache-marginalia.el
@@ -0,0 +1,124 @@
+;;; dtache-marginalia.el --- Marginalia for dtache -*- lexical-binding: t -*-
+
+;; Copyright (C) 2020-2021 Niklas Eklund
+
+;; Author: Niklas Eklund <niklas.eklund@posteo.net>
+;; URL: https://www.gitlab.com/niklaseklund/dtache.git
+;; Version: 0.1
+;; Package-Requires: ((emacs "26.1"))
+;; Keywords: convenience processes
+
+;; This file is not part of GNU Emacs.
+
+;; 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.
+
+;; 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.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This package provides a marginalia annotator for dtache.
+
+;;; Code:
+
+;;;; Requirements
+
+(require 'dtache)
+(require 'marginalia)
+
+;;;; 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)
+
+;;;; Faces
+
+(defface dtache-marginalia-git
+  '((t :inherit marginalia-char))
+  "Face used to highlight git information in `marginalia-mode'.")
+
+(defface dtache-marginalia-error
+  '((t :inherit error))
+  "Face used to highlight error in `marginalia-mode'.")
+
+(defface dtache-marginalia-active
+  '((t :inherit marginalia-file-owner))
+  "Face used to highlight active in `marginalia-mode'.")
+
+(defface dtache-marginalia-duration
+  '((t :inherit marginalia-date))
+  "Face used to highlight duration in `marginalia-mode'.")
+
+(defface dtache-marginalia-size
+  '((t :inherit marginalia-size))
+  "Face used to highlight size in `marginalia-mode'.")
+
+(defface dtache-marginalia-creation
+  '((t :inherit marginalia-date))
+  "Face used to highlight date in `marginalia-mode'.")
+
+;;;; Functions
+
+(defun dtache-marginalia-annotate (candidate)
+  "Annotate dtache CANDIDATE."
+  (let* ((session (dtache-session-decode 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))))
+
+;;;; Support functions
+
+(defun dtache-marginalia--duration (session)
+  "Return SESSION's duration time."
+  (let* ((time (round (dtache--session-duration session)))
+         (hours (/ time 3600))
+         (minutes (/ (mod time 3600) 60))
+         (seconds (mod time 60)))
+    (cond ((> time (* 60 60)) (format "%sh %sm %ss" hours minutes seconds))
+          ((> time 60) (format "%sm %ss" minutes seconds))
+          (t (format "%ss" seconds)))))
+
+(defun dtache-marginalia--creation (session)
+  "Return SESSION's creation time."
+  (format-time-string
+   "%b %d %H:%M"
+   (dtache--session-creation-time session)))
+
+(defun dtache-marginalia--size (session)
+  "Return the size of SESSION's log."
+  (file-size-human-readable
+   (dtache--session-log-size session)))
+
+(defun dtache-marginalia--git-branch (session)
+  "Return the git branch for SESSION."
+  (dtache--session-git session))
+
+(defun dtache-marginalia--active (session)
+  "Return string if SESSION is active."
+  (if (dtache--session-active session)
+      "*"
+    ""))
+
+(defun dtache-marginalia--stderr-p (session)
+  "Return string if SESSION has errors."
+  (if (dtache--session-stderr-p session)
+      "!"
+    ""))
+
+(provide 'dtache-marginalia)
+
+;;; dtache-marginalia.el ends here
diff --git a/dtache-shell.el b/dtache-shell.el
new file mode 100755
index 0000000000..e2031f6689
--- /dev/null
+++ b/dtache-shell.el
@@ -0,0 +1,136 @@
+;;; dtache-shell.el --- Shell integration of dtache -*- lexical-binding: t -*-
+
+;; Copyright (C) 2020-2021 Niklas Eklund
+
+;; Author: Niklas Eklund <niklas.eklund@posteo.net>
+;; URL: https://www.gitlab.com/niklaseklund/dtache.git
+;; Version: 0.1
+;; Package-Requires: ((emacs "26.1"))
+;; Keywords: convenience processes
+
+;; This file is not part of GNU Emacs.
+
+;; 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.
+
+;; 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.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This package provides integration of dtache into shell-mode buffers.
+
+;;;; Usage
+
+;; `dtache-shell-enable': Enable dtache in shell buffers
+
+;;; Code:
+;;;; Requirements
+
+(require 'cl-lib)
+(require 'dash)
+(require 'subr-x)
+(require 'dtache)
+(require 'comint)
+(require 's)
+(require 'shell)
+
+;;;; Functions
+
+(defun dtache-shell-enable ()
+  "Enable `dtache-shell'."
+  (add-hook 'shell-mode-hook #'dtache-shell-maybe-activate)
+  (advice-add 'shell :around #'dtache-shell--disable-histfile))
+
+(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-maybe-activate ()
+  "Only local sessions are supported."
+  (unless (file-remote-p default-directory)
+    (dtache-shell-mode)))
+
+;;;; 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."
+  (interactive "P")
+  (let ((comint-input-sender #'dtache-shell-input-sender)
+        (dtache-block-list (if disable-block '() dtache-block-list)))
+    (comint-send-input)))
+
+;;;###autoload
+(defun dtache-shell-detach ()
+  "Detach from an attached 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)))))
+
+(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))
+
+(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)))
+
+(defun dtache-shell--save-history ()
+  "Save `shell' history."
+  (comint-write-input-ring))
+
+;;;; Minor mode
+
+(define-minor-mode dtache-shell-mode
+  "Integrate `dtache' in shell-mode."
+  :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)))
+
+(provide 'dtache-shell)
+
+;;; dtache-shell.el ends here
diff --git a/dtache.el b/dtache.el
new file mode 100644
index 0000000000..1b725e98be
--- /dev/null
+++ b/dtache.el
@@ -0,0 +1,496 @@
+;;; dtache.el --- Core dtache -*- lexical-binding: t -*-
+
+;; Copyright (C) 2020-2021 Niklas Eklund
+
+;; Author: Niklas Eklund <niklas.eklund@posteo.net>
+;; URL: https://www.gitlab.com/niklaseklund/dtache.git
+;; Version: 0.1
+;; Package-Requires: ((emacs "26.1"))
+;; Keywords: convenience processes
+
+;; This file is not part of GNU Emacs.
+
+;; 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.
+
+;; 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.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; 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.
+
+;;; Code:
+
+;;;; Requirements
+
+(require 'cl-lib)
+(require 'comint)
+(require 'emacsql)
+(require 'emacsql-sqlite)
+(require 'f)
+(require 'projectile)
+
+;;;; Variables
+
+(defvar dtache-session-directory nil
+  "The directory to store `dtache' sessions.")
+(defvar dtache-db-directory user-emacs-directory
+  "The directory to store `dtache' database.")
+(defvar dtache-db nil
+  "The connection to the `dtache' database.")
+(defconst dtache-program "dtach"
+  "The `dtach' program.")
+
+(defconst dtache-shell "bash"
+  "Shell to run the dtach command in.")
+(defconst dtache-socket-ext ".socket"
+  "The file name extension for the socket for `dtache-program'.")
+(defconst dtache-log-ext ".log"
+  "The file name extension for combined stdout and stderr.")
+(defconst dtache-stdout-ext ".stdout"
+  "The file name extension for stdout.")
+(defconst dtache-stderr-ext ".stderr"
+  "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.")
+
+;;;;; Private
+
+(defvar dtache--sessions nil "A list of the current sessions.")
+
+;;;; Data structures
+
+(cl-defstruct (dtache-session (:constructor dtache--session-create)
+                              (:conc-name dtache--session-))
+  (id nil :read-only t)
+  (command nil :read-only t)
+  (directory nil :read-only t)
+  (creation-time nil :read-only t)
+  (git nil :read-only t)
+  (duration nil)
+  (log-size nil)
+  (stderr-p nil)
+  (active nil))
+
+;;;; Interfaces
+
+(cl-defgeneric dtache-attach (session)
+  "A context aware function to attach to SESSION.")
+
+(cl-defmethod dtache-attach (session &context (major-mode shell-mode))
+  "Attach to a dtache SESSION when MAJOR-MODE is `shell-mode'.
+
+`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)))))
+
+;;;; Commands
+
+;;;###autoload
+(defun dtache-compile-session (session)
+  "Open log of SESSION in `compilation-mode'."
+  (interactive
+   (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))
+      (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))
+        (compilation-mode))
+      (pop-to-buffer buffer-name))))
+
+;;;###autoload
+(defun dtache-copy-session-content (session)
+  "Copy content of SESSION."
+  (interactive
+   (list (dtache-select-session)))
+  (dtache--file-content (dtache--session-file session 'log)))
+
+;;;###autoload
+(defun dtache-copy-session (session)
+  "Copy SESSION."
+  (interactive
+   (list (dtache-select-session)))
+  (kill-new (dtache--session-command session)))
+
+;;;###autoload
+(defun dtache-insert-session (session)
+  "Insert SESSION."
+  (interactive
+   (list (dtache-select-session)))
+  (insert (dtache--session-command session)))
+
+;;;###autoload
+(defun dtache-remove-session (session)
+  "Remove SESSION."
+  (interactive
+   (list (dtache-select-session)))
+  (if (dtache--session-active-p session)
+      (message "Kill session first before removing it.")
+    (dtache--db-remove-session session)))
+
+;;;###autoload
+(defun dtache-kill-session (session)
+  "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)))))
+
+;;;###autoload
+(defun dtache-open-log (session)
+  "Open SESSION's log."
+  (interactive
+   (list (dtache-select-session)))
+  (dtache--open-file session 'log))
+
+;;;###autoload
+(defun dtache-open-stdout (session)
+  "Open SESSION's stdout."
+  (interactive
+   (list (dtache-select-session)))
+  (dtache--open-file session 'stdout))
+
+;;;###autoload
+(defun dtache-open-stderr (session)
+  "Open SESSION's stderr."
+  (interactive
+   (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 (string pred action)
+                             (if (eq action 'metadata)
+                                 '(metadata (category . dtache)
+                                            (cycle-sort-function . identity)
+                                            (display-sort-function . identity))
+                               ;; TODO: Tweak this and implement full
+                               ;; programable completion
+                               (complete-with-action
+                                action sessions string 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))))
+
+(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))))
+
+(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
+                                 :creation-time (time-to-seconds 
(current-time))
+                                 :git (dtache--session-git-info)
+                                 :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-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)
+       "..."
+       (s-right (/ part-length 2) command)))))
+
+(defun dtache-session--update (session)
+  "Update the `dtache' SESSION."
+  ;; TODO: Make this function private
+  (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))))
+  (setf (dtache--session-stderr-p session) (> (file-attribute-size
+                                               (file-attributes
+                                                (dtache--session-file session 
'stderr))) 0))
+  session)
+
+(defun dtache--session-git-info ()
+  "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
+
+(defun dtache--session-short-id (session)
+  "Return the short representation of the SESSION's id."
+  (s-right 8 (dtache--session-id session)))
+
+(defun dtache--session-active-p (session)
+  "Return t if SESSION is active."
+  (f-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)))
+
+;;;;; Database
+
+(defun dtache--db-insert-session (session)
+  "Insert SESSION into the database."
+  (let ((id (dtache--session-id session)))
+    (emacsql dtache-db `[:insert
+                         :into dtache-sessions
+                         :values ([,id ,session])])))
+
+(defun dtache--db-update-session (session)
+  "Update the database with SESSION."
+  (let ((id (dtache--session-id session)))
+    (emacsql dtache-db [:update dtache-sessions
+                        :set (= dtache-session $s2)
+                        :where (= id $s1)]
+             id session)))
+
+(defun dtache--db-remove-session (session)
+  "Remove SESSION from the database."
+  (let ((id (dtache--session-id session)))
+    (emacsql dtache-db [:delete
+                        :from dtache-sessions
+                        :where (= id $s1)]
+             id)))
+
+(defun dtache--db-select-session (id)
+  "Return the session with ID from the database."
+  (caar
+   (emacsql dtache-db [:select dtache-session
+                       :from dtache-sessions
+                       :where (= id $s1)]
+            id)))
+
+(defun dtache--db-select-sessions ()
+  "Return all sessions from the database."
+  (let ((sessions
+         (emacsql dtache-db
+                  [:select dtache-session
+                   :from dtache-sessions])))
+    (-map #'car sessions)))
+
+;;;; Major modes
+
+(defvar dtache-log-mode-map
+  (let ((map (make-sparse-keymap)))
+    map)
+  "Keymap for `dtache-log-mode'.")
+
+(define-derived-mode dtache-log-mode nil "Dtache Log"
+  "Major mode for dtache logs.")
+
+(provide 'dtache)
+
+;;; dtache.el ends here
diff --git a/notes.org b/notes.org
new file mode 100644
index 0000000000..33f68bb509
--- /dev/null
+++ b/notes.org
@@ -0,0 +1,24 @@
+* Improvements
+** Support byte compilation
+** Handling large files
+
+Opening a large file yields the following warning.
+
+#+begin_src text
+  Warning (undo): Buffer ‘*dtache*’ undo info was 219405582 bytes long.
+  The undo info was discarded because it exceeded `undo-outer-limit'.
+
+  This is normal if you executed a command that made a huge change
+  to the buffer.  In that case, to prevent similar problems in the
+  future, set `undo-outer-limit' to a value that is large enough to
+  cover the maximum size of normal changes you expect a single
+  command to make, but not so large that it might exceed the
+  maximum memory allotted to Emacs.
+
+  If you did not execute any such command, the situation is
+  probably due to a bug and you should report it.
+
+  You can disable the popping up of this buffer by adding the entry
+  (undo discard-info) to the user option `warning-suppress-types',
+  which is defined in the `warnings' library.
+#+end_src
diff --git a/test/dtache-marginalia-test.el b/test/dtache-marginalia-test.el
new file mode 100644
index 0000000000..0202fe1c92
--- /dev/null
+++ b/test/dtache-marginalia-test.el
@@ -0,0 +1,61 @@
+;;; dtache-marginalia-test.el --- Tests for dtache-marginalia.el -*- 
lexical-binding: t; -*-
+
+;; Copyright (C) 2020-2021  Niklas Eklund
+
+;; Author: Niklas Eklund <niklas.eklund@posteo.net>
+;; Url: https://gitlab.com/niklaseklund/dtache
+;; Package-requires: ((emacs "26.1"))
+;; Version: 0.1
+
+;; 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.
+
+;; 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.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Tests for dtache-marginalia
+
+;;; Code:
+
+(require 'ert)
+(require 'dtache-marginalia)
+
+(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 dtache-marginalia-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))))))
+
+(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 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 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 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)))))
+
+(provide 'dtache-marginalia-test)
+
+;;; dtache-marginalia-test.el ends here
diff --git a/test/dtache-shell-test.el b/test/dtache-shell-test.el
new file mode 100644
index 0000000000..91e2b70998
--- /dev/null
+++ b/test/dtache-shell-test.el
@@ -0,0 +1,42 @@
+;;; dtache-shell-test.el --- Tests for dtache-shell.el -*- lexical-binding: t; 
-*-
+
+;; Copyright (C) 2020-2021  Niklas Eklund
+
+;; Author: Niklas Eklund <niklas.eklund@posteo.net>
+;; Url: https://gitlab.com/niklaseklund/dtache
+;; Package-requires: ((emacs "26.1"))
+;; Version: 0.1
+
+;; 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.
+
+;; 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.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Tests for dtache-shell
+
+;;; Code:
+
+(require 'ert)
+(require 'dtache-shell)
+
+;;;; Tests
+
+(ert-deftest dtache-shell-test-filter-eof ()
+  (let ((str "
+[EOF - dtach terminating]
+user@machine "))
+    (should (string= "
\nuser@machine " (dtache-shell--filter-dtach-eof str)))))
+
+(provide 'dtache-shell-test)
+
+;;; dtache-shell-test.el ends here
diff --git a/test/dtache-test.el b/test/dtache-test.el
new file mode 100644
index 0000000000..2e0355daac
--- /dev/null
+++ b/test/dtache-test.el
@@ -0,0 +1,57 @@
+;;; dtache-test.el --- Tests for dtache.el -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2020-2021  Niklas Eklund
+
+;; Author: Niklas Eklund <niklas.eklund@posteo.net>
+;; Url: https://gitlab.com/niklaseklund/dtache
+;; Package-requires: ((emacs "26.1"))
+;; Version: 0.1
+
+;; 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.
+
+;; 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.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Tests for dtache
+
+;;; Code:
+
+(require 'ert)
+(require 'dtache)
+
+;;; Tests
+
+(ert-deftest dtache-test-session-short-id ()
+  (let ((session (dtache--session-create :id "abcdefg12345678")))
+    (should (string= "12345678" (dtache--session-short-id session)))))
+
+(ert-deftest dtache-test-session-truncate-command ()
+  (let ((dtache-max-command-length 7))
+    (should (string= "12...78"
+                     (dtache--session-truncate-command
+                      (dtache--session-create :command "12345678")))))
+  (let ((dtache-max-command-length 6))
+    (should (string= "1...8"
+                     (dtache--session-truncate-command
+                      (dtache--session-create :command "12345678"))))))
+
+(ert-deftest dtache-test-session-encode ()
+  (let ((session
+         (dtache--session-create :command "abcdefghijk"
+                                 :id "-------12345678"))
+        (dtache-max-command-length 8))
+    (should (string= "ab...jk  12345678" (dtache-session-encode session)))))
+
+(provide 'dtache-test)
+
+;;; dtache-test.el ends here



reply via email to

[Prev in Thread] Current Thread [Next in Thread]