ambevar-dotfiles/.local/share/common-lisp/source/ambrevar/shell.lisp

(uiop:define-package #:ambrevar/shell
  (:documentation "Shell-like utilities.")
  (:nicknames #:$)
  (:use #:common-lisp)
  (:use #:trivia)
  (: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 ()
  "Return the environment variables as an alist."
  (mapcar (lambda (line)
            (str:split "=" line :limit 2))
          (str:split (string #\newline) (run* "env"))))

(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)))


(defvar %magic-cookie-mime-type (magicffi:magic-open '(:symlink :mime-type))
  "Internal, persistent cookie for `magicffi' calls.

Benchmark on thousands of files shows that
keeping the same cookie saves about 15% of time.")
(magicffi:magic-load %magic-cookie-mime-type)

(defvar %magic-cookie-mime (magicffi:magic-open '(:symlink :mime))
  "See `%magic-cookie-mime-type'. ")
(magicffi:magic-load %magic-cookie-mime)

(defvar %magic-cookie-description (magicffi:magic-open '(:symlink))
  "See `%magic-cookie-mime-type'. ")
(magicffi:magic-load %magic-cookie-description)

(export-always 'file-mime-type)
(defun file-mime-type (file)
  "Return the FILE MIME type."
  (magicffi:magic-file %magic-cookie-mime-type file))

(export-always 'file-mime)
(defun file-mime (file)
  "Return a pair of MIME type and MIME encoding for FILE."
  (str:split "; "
   (magicffi:magic-file %magic-cookie-mime file)))

(export-always 'file-description)
(defun file-description (file)
  "Return the FILE description as per the `file' UNIX command."
  (magicffi:magic-file %magic-cookie-description file))

(export-always 'file-extension)
(defun file-extension (file)
  "Return the file extension.
If none, return the empty string unlike `pathname-type'."
  (or (pathname-type file)
      ""))

(export-always 'file-basename)
(defun file-basename (file)
  "Return the file basename (including the extension)."
  (apply #'str:concat (pathname-name file)
         (sera:and-let* ((ext (file-extension file)))
           `("." ,ext))))

(export-always 'match-extensions)
(defun match-extensions (extension &rest more-extensions)
  "Return a predicate for files that match on of the provided extensions.
Useful for `finder'."
  (lambda (file)
    (some (lambda (ext)
            (string= ext (pathname-type file)))
          (cons extension more-extensions))))

(export-always 'match-name)
(defun match-name (name &rest more-names)
  "Return a predicate that matches when one of the names is contained in the
file basename.
Basename includes the extension.  Useful for `finder'."
  (lambda (file)
    (some (lambda (name)
            (str:contains? name (file-basename file)))
          (cons name more-names))))

(export-always 'match-directory)
(defun match-directory (&key (empty? t) (non-empty? t) (files? t))
  "Return a predicate that matches on directories.
If target is a file, return FILES?.
Useful for `walk'."
  (lambda (directory)
    (if (uiop:directory-exists-p directory)
        (let ((files-or-dirs? (or (uiop:directory-files directory)
                                  (uiop:subdirectories directory))))
          (or (and empty?
                   (not files-or-dirs?))
              (and non-empty?
                   files-or-dirs?)))
        files?)))

(export-always 'match-executable)
(defun match-executable ()
  (lambda (file)
    (intersection
     (osicat:file-permissions file)
     '(:user-exec :group-exec :other-exec))))

(export-always 'match-elf-binary)
(defun match-elf-binary ()
  (lambda (file)
    (string= "application/x-executable" (file-mime-type file))))

(export-always 'match-elf-library)
(defun match-elf-library ()
  (lambda (file)
    (ppcre:scan "application/x-sharedlib" (first (file-type file)))))

(export-always '*finder-include-directories*)
(defvar *finder-include-directories* t
  "When non-nil `walk' include directories.")

(export-always 'directory-listing)      ; TODO: Rename list-directory?
(defun directory-listing (path &key sort?)
  "Return entries in PATH.
If SORT?, sort them alphabetically."
  ;; TODO: Use locale to sort?
  (let ((result
          (append (uiop:subdirectories path)
                  (uiop:directory-files path))))
    (if sort?
        (sort result #'string< :key #'namestring)
        result)))

(export-always 'walk)
(defun walk (root &rest predicates)
  "List files and directories that satisfy all PREDICATES.
Without PREDICATES, list all files."
  (let ((result '()))
    (uiop:collect-sub*directories
     (uiop:ensure-directory-pathname root)
     (constantly t) (constantly t)
     (lambda (subdirectory)
       (setf result (nconc result
                           (let ((subfiles (append (if *finder-include-directories* (list subdirectory) nil)
                                                   (uiop:directory-files subdirectory))))
                             (if predicates
                                 (delete-if (lambda (file)
                                              (notany (lambda (pred) (funcall pred file))
                                                      predicates))
                                            subfiles)
                                 subfiles))))))
    result))

(export-always 'finder)
(defun finder (root &rest predicates)
  "List files in ROOT that satisfy all PREDICATES.
Without PREDICATES, list all files."
  (let ((*finder-include-directories* nil))
    (apply #'walk root predicates)))

(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 kill (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 pids))))

(defun terminate-process-with-group (process-info)
  (when (uiop:process-alive-p process-info)
    (kill (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))

(defun %run (command &key (output :stream) (error-output *error-output*))
  (assert-program "pkill")              ; For `terminate-process-with-group'.
  (flet ((cleanup (process-info)
           (push process-info *process-list*)
           (uiop:wait-process process-info)))
    (setf command (if (listp command)
                      (mapcar #'princ-to-string (alex:flatten command))
                      command))
    ;; TODO: Use :stream directly in launch-program and get stream from
    ;; process-info to avoid repeating the launch-program call.
    (match output
      (:stream
       (nth-value
        0
        (uiop:stripln
         (with-output-to-string (out)
           (let ((process-info (uiop:launch-program command
                                                    :output out
                                                    :error-output error-output)))
             (cleanup process-info))))))

      (out
       (let ((process-info (uiop:launch-program command
                                                :output (match out
                                                          (t *standard-output*)
                                                          (o o))
                                                :error-output error-output)))
         (cleanup process-info))))))

(export-always 'run)
(defun run (command &rest args)
  "Run arguments in a safe manner.
If on interrupt process gets forked to the background, call
`terminate-dangling-processes'.
Output is sent to `*standard-output*'.
Arguments are automatically converted to strings with `format'.
Lists are automatically flattened."
  (%run (cons command args) :output t))

(export-always 'run*)
(defun run* (command &rest args)
  "Same as `run' but return output as a string."
  (%run (cons command args)))

(export-always 'sh)
(defun sh (shell-command)
  "Like `run' but for shell commands."
  (%run shell-command :output t))

(export-always 'sh*)
(defun sh* (shell-command)
  "Like `sh' but return output as a string."
  (%run shell-command))

(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)
            (delete "" (ppcre:split "\\s+" line) :test #'string=))
          (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
                             (run* "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 'checksum)
(defun checksum (file)                  ; TODO: Use pure CL version.
  "Return checksum of FILE."
  (first (first (tokenize (run* "sha1sum" file)))))

(export-always 'relative-path)
(defun relative-path (path &optional (parent-directory *default-pathname-defaults*))
  "Return PATH relative to PARENT-DIRECTORY.
If PARENT-DIRECTORY is not a parent of PATH, return PATH."
  (or (uiop:subpathp (uiop:merge-pathnames* path) ; The `merge-pathnames*' ensure PATH is absolute.
                     (uiop:ensure-directory-pathname parent-directory))
      path))

(export-always 'toggle-interpol-readtable)
(defun toggle-interpol-readtable ()
  (if (eq *readtable* (named-readtables:find-readtable :interpol-syntax))
      (named-readtables:in-readtable :standard)
      (named-readtables:in-readtable :interpol-syntax)))

(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)))
    (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 (run* "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)))