(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) (cmd:$cmd "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 '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-mime-type file)))))

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

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

(export-always 'tee)
(defun tee (input-stream)
  "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" 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)))
    (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)))