385 lines
14 KiB
Common Lisp
385 lines
14 KiB
Common Lisp
(uiop:define-package ambrevar/shell
|
|
(:documentation "Shell-like utilities.")
|
|
;; (:nicknames #:$)
|
|
(:use #:common-lisp)
|
|
(:use #:trivia)
|
|
(:import-from #:ambrevar/file)
|
|
(:import-from #:serapeum #:export-always))
|
|
(in-package ambrevar/shell)
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(trivial-package-local-nicknames:add-package-local-nickname :alex :alexandria)
|
|
(trivial-package-local-nicknames:add-package-local-nickname :sera :serapeum))
|
|
|
|
(export-always 'date)
|
|
(defun date ()
|
|
(local-time:format-rfc1123-timestring nil (local-time:now)))
|
|
|
|
(export-always 'env)
|
|
(defun env (&optional key)
|
|
"Return the environment variables as a proper alist.
|
|
With KEY, return the corresponding environment variable value, and the whole
|
|
list as a second value."
|
|
(let ((result
|
|
(mapcar (lambda (line)
|
|
(let ((key-value (str:split "=" line :limit 2)))
|
|
(cons (first key-value)
|
|
(str:split (uiop:inter-directory-separator)
|
|
(second key-value)))))
|
|
(str:split (string #\newline) (cmd:$cmd "env")))))
|
|
(if key
|
|
(alex:assoc-value result key :test #'string=)
|
|
result)))
|
|
|
|
(export-always 'file->string)
|
|
(defun file->string (path)
|
|
(sera:chomp (alex:read-file-into-string path)))
|
|
|
|
(defun assert-program (program &rest more-programs) ; TODO: Is this useful for a REPL?
|
|
(sera:and-let* ((missing-programs
|
|
(delete-if #'sera:resolve-executable (cons program more-programs))))
|
|
(error "Missing programs: ~{~a~,^, ~}" missing-programs)))
|
|
|
|
(export-always 'delete-empty-directory-upward)
|
|
(defun delete-empty-directory-upward (directory)
|
|
"Delete directory and its parents until non-empty.
|
|
Return the first non-deleted directory."
|
|
(or (and (ignore-errors (uiop:delete-empty-directory directory))
|
|
(delete-empty-directory-upward
|
|
(uiop:pathname-parent-directory-pathname
|
|
(uiop:ensure-directory-pathname directory))))
|
|
directory))
|
|
|
|
(export-always 'make-directory)
|
|
(defun make-directory (path)
|
|
"Including parents."
|
|
(uiop:ensure-all-directories-exist (list (uiop:ensure-directory-pathname path)))
|
|
path)
|
|
|
|
(defun system-signal (pid-or-pids &key (signal 'term) options)
|
|
"OPTIONS are PKILL options."
|
|
;; TODO: Is it possible to kill a group without pkill, maybe with osicat?
|
|
(uiop:run-program
|
|
(append
|
|
(list (if options "pkill" "kill") (format nil "-~a" signal))
|
|
options
|
|
(mapcar #'princ-to-string (alex:ensure-list pid-or-pids)))))
|
|
|
|
(defun kill (pid-or-pids)
|
|
"Kill PID-OR-PIDS (with SIGKILL)."
|
|
(system-signal pid-or-pids :signal 'kill))
|
|
|
|
(defun term (pid-or-pids)
|
|
"Cleanly terminate PID-OR-PIDS."
|
|
(system-signal pid-or-pids :signal 'term))
|
|
|
|
(defun terminate-process-with-group (process-info)
|
|
(when (uiop:process-alive-p process-info)
|
|
(system-signal
|
|
(list (format nil "~a" (osicat-posix:getpgid (uiop:process-info-pid process-info))))
|
|
:signal 'term ;TODO: -KILL instead?
|
|
:options '("-g"))
|
|
(uiop:terminate-process process-info)))
|
|
|
|
(defvar *process-list* '()
|
|
"List of processes started from `run'.")
|
|
|
|
;; (export-always 'terminate-dangling-processes)
|
|
;; (defun terminate-dangling-processes ()
|
|
;; (mapc #'terminate-process-with-group *process-list*)
|
|
;; ;; TODO: Maybe don't flush the list in case some processes failed to be terminated.
|
|
;; ;; Use -KILL to fix this?
|
|
;; (setf *process-list* nil))
|
|
|
|
(export-always '*shell*)
|
|
(defvar *shell* "sh"
|
|
"Default shell to use in `sh' and friends.
|
|
Also see `*shell-command-flags*'.")
|
|
|
|
(export-always '*shell-command-flag*)
|
|
(defvar *shell-command-flag* "-c"
|
|
"Flag to pass a command string to the `*shell*'.")
|
|
|
|
(defun format-shell-command (shell-command)
|
|
(format nil "~a ~a '~a'"
|
|
*shell* *shell-command-flag* shell-command))
|
|
|
|
(export-always 'sh)
|
|
(defun sh (shell-command)
|
|
"Wrapper around `cmd:cmd' to execute SHELL-COMMAND in `*shell*'."
|
|
(cmd:cmd (format-shell-command shell-command)))
|
|
|
|
(export-always 'sh&)
|
|
(defun sh& (shell-command)
|
|
"Wrapper around `cmd:cmd&' to execute SHELL-COMMAND in `*shell*'."
|
|
(cmd:cmd& (format-shell-command shell-command)))
|
|
|
|
(export-always '$sh)
|
|
(defun $sh (shell-command)
|
|
"Wrapper around `cmd:$cmd' to execute SHELL-COMMAND in `*shell*'."
|
|
(cmd:$cmd (format-shell-command shell-command)))
|
|
|
|
(export-always 'cmd&)
|
|
(defun cmd& (cmd) ; TODO: Support (cmd &rest args) lambda list.
|
|
"Like `cmd:cmd&' but run and monitor in a shell.
|
|
When Lisp is exited, the command is automatically terminated.
|
|
List of background process is maintained in `*process-list*'."
|
|
(let* ((cmd (format nil
|
|
"bash -c 'set -o monitor; { ~a ; kill $$ ; } & read dummy; kill %1'" cmd))
|
|
(handle (cmd:cmd& cmd :input :stream)))
|
|
(push handle *process-list*)
|
|
handle))
|
|
|
|
(export-always 'cmd>)
|
|
(defun cmd> (cmd &rest args) ; TODO: "|" is not convenient in CL, use "/" or "-"? See `cmd<>'.
|
|
"Like `cmd:cmd&' but return the output as a stream.
|
|
Return the process handler as second value.
|
|
Use
|
|
|
|
(uiop:slurp-stream-string STREAM :stripped t)
|
|
|
|
to get the final output as a string."
|
|
(let ((handler (apply #'cmd:cmd& cmd (append args
|
|
(list :output :stream)))))
|
|
(values (uiop:process-info-output handler)
|
|
handler)))
|
|
|
|
(export-always 'cmd<>)
|
|
(defun cmd<> (cmd &rest args)
|
|
"Like `cmd>' but last argument is passed as `:input'.
|
|
This can be usefully chained, e.g. with arrow macros.
|
|
Example:
|
|
|
|
(->>
|
|
(cmd> \"cat\" \".../share/hunspell/en_GB-large.dic\")
|
|
(cmd<> \"sort\")
|
|
(cmd<> \"uniq\" \"-c\")
|
|
(cmd<> \"sort\" \"-nr\")
|
|
(cmd<> \"head\" \"-3\"))"
|
|
(let* ((butlast-args (butlast args))
|
|
(last-arg (first (last args)))
|
|
(handler (apply #'cmd:cmd& cmd (append butlast-args
|
|
(list :output :stream
|
|
:input last-arg)))))
|
|
(values (uiop:process-info-output handler)
|
|
handler)))
|
|
|
|
(export-always 'cmd<)
|
|
(defun cmd< (cmd &rest args)
|
|
"Like `cmd<>' but output to standard output."
|
|
(let* ((butlast-args (butlast args))
|
|
(last-arg (first (last args))))
|
|
(apply #'cmd:cmd cmd (append butlast-args
|
|
(list :input last-arg)))))
|
|
|
|
(export-always '$cmd<)
|
|
(defun $cmd< (cmd &rest args)
|
|
"Like `cmd<>' but return string."
|
|
(let* ((butlast-args (butlast args))
|
|
(last-arg (first (last args))))
|
|
(apply #'cmd:$cmd cmd (append butlast-args
|
|
(list :input last-arg)))))
|
|
|
|
(defun %cmd- (final-caller &rest args)
|
|
"See `cmd-'."
|
|
(let ((arg-lists (sera:split-sequence :- args)))
|
|
(sera:nlet call ((arg-lists arg-lists)
|
|
(last-result-stream nil))
|
|
(let* ((args (first arg-lists)))
|
|
(if (rest arg-lists)
|
|
(let ((handler
|
|
(apply #'cmd:cmd&
|
|
(first args)
|
|
(append (rest args)
|
|
(list :output :stream)
|
|
(when last-result-stream
|
|
(list :input last-result-stream))))))
|
|
(call (rest arg-lists) (uiop:process-info-output handler)))
|
|
(apply final-caller (first args)
|
|
(append (rest args)
|
|
(when last-result-stream
|
|
(list :input last-result-stream)))))))))
|
|
|
|
(export-always 'cmd-)
|
|
(defun cmd- (&rest args)
|
|
"Call `:-'-separated commands in args, passing the result of one onto the next.
|
|
Example:
|
|
|
|
(cmd- \"cat\" \".../share/hunspell/en_GB-large.dic\"
|
|
:- \"sort\"
|
|
:- \"uniq\" \"-c\"
|
|
:- \"sort\" \"-nr\"
|
|
:- \"head\" \"-3\")"
|
|
(apply #'%cmd- #'cmd:cmd args))
|
|
|
|
(defun $cmd- (&rest args)
|
|
"Like `cmd-' but return a string."
|
|
(apply #'%cmd- #'cmd:$cmd args))
|
|
|
|
(defun cmd-& (&rest args)
|
|
"Like `cmd-' but return a `process-info' object."
|
|
(apply #'%cmd- #'cmd:cmd& args))
|
|
|
|
(defun cmd-> (&rest args)
|
|
"Like `cmd-' but return a stream."
|
|
(apply #'%cmd- #'cmd> args))
|
|
|
|
(defvar *visual-command* '("htop"))
|
|
(defvar *command-wrappers* '("sudo" "env"))
|
|
(defun visual-command-p (command)
|
|
"Return true if the COMMAND list runs one of the programs in `*visual-command*'.
|
|
`*command-wrappers*' are supported, i.e.
|
|
|
|
env FOO=BAR sudo -i powertop
|
|
|
|
works."
|
|
(labels ((basename (arg)
|
|
(namestring (pathname-name arg)))
|
|
(flag? (arg)
|
|
(str:starts-with? "-" arg))
|
|
(variable? (arg)
|
|
(and (< 1 (length arg))
|
|
(str:contains? "=" (subseq arg 1))))
|
|
(first-positional-argument (command)
|
|
"Return the argument that's not a flag, not a variable setting and
|
|
not in `*command-wrappers*'."
|
|
(when command
|
|
(if (or (flag? (first command))
|
|
(variable? (first command))
|
|
(find (basename (first command))
|
|
*command-wrappers*
|
|
:test #'string=))
|
|
(first-positional-argument (rest command))
|
|
(first command)))))
|
|
(sera:and-let* ((cmd (first-positional-argument command)))
|
|
(find (basename cmd)
|
|
*visual-command*
|
|
:test #'string=))))
|
|
|
|
(defun vterm-terminal (cmd)
|
|
(list
|
|
"emacsclient" "--eval"
|
|
(let ((*print-case* :downcase))
|
|
(write-to-string
|
|
`(progn
|
|
(vterm)
|
|
(vterm-insert ,(str:join " " cmd))
|
|
(vterm-send-return))))))
|
|
|
|
(defvar *terminal* '("/gnu/store/751mcahyg3b5dpwkbfvzg6x1vdn9i49a-xterm-363/bin/xterm" "-e")
|
|
"The terminal is either a list of arguments after which will be prepended to
|
|
the visual command to run, or a function of one argument, the list of commands,
|
|
returning the new list of commands.")
|
|
|
|
(defun maybe-launch-visual-command (cmd)
|
|
(if (visual-command-p cmd)
|
|
(cmd:cmd
|
|
(if (functionp *terminal*)
|
|
(funcall *terminal* cmd)
|
|
(append *terminal* cmd)))
|
|
(cmd:cmd cmd)))
|
|
|
|
(setf *terminal* #'vterm-terminal)
|
|
|
|
;; (maybe-launch-visual-command '("htop"))
|
|
|
|
(export-always 'tee)
|
|
(defun tee (input-stream) ; TODO: Real `tee' with separate process.
|
|
"Return the INPUT-STREAM and its string representation as a second value."
|
|
(let ((result
|
|
(uiop:slurp-stream-string input-stream :stripped t)))
|
|
(values
|
|
(make-string-input-stream result)
|
|
result)))
|
|
|
|
(export-always 'disk-usage)
|
|
(defun disk-usage (files)
|
|
"Return disk usage of FILES in octets.
|
|
As a second value, return a list of (FILE SIZE) pairs, biggest file first."
|
|
(let ((pairs (mapcar (lambda (f)
|
|
(list f (or (trivial-file-size:file-size-in-octets f)
|
|
0)))
|
|
files)))
|
|
(values
|
|
(reduce #'+ (mapcar #'second pairs))
|
|
(sort
|
|
pairs
|
|
#'> :key #'second))))
|
|
|
|
(export-always 'tokenize)
|
|
(defun tokenize (string)
|
|
"Return list of STRING lines, where each line is a list of each word."
|
|
(mapcar (lambda (line)
|
|
(sera:tokens line))
|
|
(str:split (string #\newline) string)))
|
|
|
|
(export-always 'port-process)
|
|
(defun port-process (port)
|
|
"Return process PID using PORT, NIL is none.
|
|
Return process name as second value."
|
|
(sera:and-let* ((ss-line (first
|
|
(tokenize
|
|
(cmd:$cmd "ss"
|
|
"--no-header"
|
|
"--listening"
|
|
"--tcp"
|
|
"--processes"
|
|
(format nil "( dport = :~a or sport = :~a )" port port)))))
|
|
(process-desc (first (last ss-line)))
|
|
(process-desc-no-prefix (second (str:split ":" process-desc)))
|
|
(process-props (first
|
|
(read-from-string
|
|
(str:replace-all "," " " process-desc-no-prefix))))
|
|
(process-name (first process-props))
|
|
(process-pid-prop (find-if (lambda (prop) (str:starts-with? "PID=" (string prop))) process-props))
|
|
(process-pid-string (second (str:split "=" (string process-pid-prop))))
|
|
(process-pid (parse-integer process-pid-string)))
|
|
(values
|
|
process-pid
|
|
process-name)))
|
|
|
|
(export-always 'sha1)
|
|
(defun sha1 (file) ; TODO: Use pure CL / FFI version?
|
|
"Return checksum of FILE."
|
|
(first (first (tokenize (cmd:$cmd "sha1sum" (write-to-string (ambrevar/file:path file)))))))
|
|
|
|
(export-always 'move-file)
|
|
(defun move-file (source destination)
|
|
"`rename-file' does not work cross-device, in particular it does not work on
|
|
different Btrfs subvolumes."
|
|
(uiop:run-program (list "mv"
|
|
;; Use native-namestring in case path contains escaped
|
|
;; character, like "\\[".
|
|
(uiop:native-namestring source)
|
|
(uiop:native-namestring destination))))
|
|
|
|
(defun loopback? (interface)
|
|
(or (string= "link/loopback" (first (second interface)))
|
|
(string= "lo:" (second (first interface)))))
|
|
|
|
(defun ipv4 (interface)
|
|
(when (string= "inet" (first (third interface)))
|
|
(values (ppcre:regex-replace "/.*" (second (third interface)) ""))))
|
|
|
|
;; TODO: Make class for interfaces? Can iolib / usocket be helpful here?
|
|
(defun interfaces (&optional interface)
|
|
"Return IP of current INTERFACE.
|
|
INTERFACE is a string in the form of `wlp2s0'."
|
|
(let* ((raw-list (tokenize (cmd:$cmd "ip" "address" interface))))
|
|
(sera:collecting
|
|
(sera:do-splits ((l r) (raw-list (lambda (line)
|
|
(ppcre:scan "[0-9]+:" (first line)))))
|
|
(sera:and-let* ((split (subseq raw-list (max 0 (1- l)) r)))
|
|
(collect split))))))
|
|
|
|
(defun interfaces-with-ipv4 ()
|
|
"Return list of interfaces with ipv4, excluding the loopback."
|
|
(remove-if (complement #'ipv4)
|
|
(remove-if #'loopback? (interfaces))))
|
|
|
|
(defun current-interface ()
|
|
(first (interfaces-with-ipv4)))
|
|
|
|
(export-always 'current-ip)
|
|
(defun current-ip ()
|
|
(ipv4 (current-interface)))
|