tinmop/src/os-utils.lisp

;; tinmop: a multiprotocol client
;; Copyright © cage

;; 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/>.

(in-package :os-utils)

(alexandria:define-constant +proc-file-system+
    (concatenate 'string filesystem-utils:*directory-sep*
                 "proc")
  :test #'string=)

(alexandria:define-constant +proc-cpuinfo+
    (concatenate 'string +proc-file-system+ filesystem-utils:*directory-sep*
                 "cpuinfo")
  :test #'string=)

(alexandria:define-constant +ssl-cert-name+ "cert.pem" :test #'string=)

(alexandria:define-constant +ssl-key-name+  "key" :test #'string=)

(declaim (ftype (function () fixnum) cpu-number))

(defun cpu-number ()
  #+windows (the fixnum 1)
  #-windows
  (with-open-file (stream +proc-cpuinfo+ :direction :input
                            :if-does-not-exist :error)
    (do ((line (read-line stream nil nil) (read-line stream nil nil))
         (cpu-count 0))
        ((not line) (the fixnum cpu-count))
      (when (cl-ppcre:scan "^processor" line)
        (incf cpu-count)))))

(defun xdg-open (file)
  (let ((cmd-line (format nil "~a '~a'" +xdg-open-bin+ file)))
    #+debug-mode
    (misc:dbg "xdg-open: ~a" cmd-line)
    (uiop:launch-program cmd-line :output nil)))

(defun getenv (name &key (default nil))
  (or (uiop:getenv name)
      default))

(defun default-temp-dir ()
  (getenv "TMPDIR" :default "/tmp/"))

(defun pwd ()
  (getenv "PWD"))

(defun home-directory (&key (add-separator-ends nil))
  (let ((home (os-utils:getenv "HOME")))
    (if add-separator-ends
        (text-utils:strcat home fs:*directory-sep*)
        home)))

(defstruct user-info
  (name)
  (password)
  (user-id)
  (group-id)
  (gecos)
  (home)
  (shell))

(defun user-info (id)
  "USER-INFO returns the password entry for the given name or
numerical user ID, as an assoc-list."
  (a:when-let ((password-struct (etypecase id
                                  (string  (nix:getpwnam id))
                                  (integer (nix:getpwuid id)))))
    (make-user-info :name     (nix:passwd-name password-struct)
                    :password (nix:passwd-passwd password-struct)
                    :user-id  (nix:passwd-uid password-struct)
                    :group-id (nix:passwd-gid password-struct)
                    :gecos    (nix:passwd-gecos password-struct)
                    :home     (nix:passwd-dir password-struct)
                    :shell    (nix:passwd-shell password-struct))))

(defun external-editor ()
  (let* ((editor (or (swconf:external-editor)
                     (and (text-utils:string-not-empty-p (getenv "VISUAL"))
                          (getenv "VISUAL"))
                     (and (text-utils:string-not-empty-p (getenv "EDITOR"))
                          (getenv "EDITOR"))
                     constants:+standard-editor+))
         (space (cl-ppcre:scan "\\s" editor)))
    (if space
        (let ((exe  (subseq editor 0 space))
              (args (subseq editor (1+ space))))
          (values exe args))
        (values editor nil))))

(defun run-external-program (program args
                             &key
                               (wait t)
                               search
                               input
                               output
                               (error :output)
                               (external-format :default)
                               #+sbcl (if-output-exists :supersede)
                               #+sbcl (if-error-exists :supersede))
  (declare (ignorable search))
  #+ecl (ext:run-program program
                         args
                         :input  input
                         :output output
                         :error  error
                         :wait   wait)
  #+sbcl (sb-ext:run-program program
                             args
                             :wait   wait
                             :search search
                             :input  input
                             :output output
                             :error  error
                             :external-format external-format
                             :if-output-exists if-output-exists
                             :if-error-exists if-error-exists))

(defun process-exit-code (process)
  #+ecl  (nth-value 1 (ext:external-process-status process))
  #+sbcl (sb-ext:process-exit-code process))

(defun process-exit-success-p (process)
  (= (process-exit-code process) 0))

(defun process-output-stream (process)
  (process-output process))

(defmacro gen-process-stream (name)
  `(defun ,(misc:format-fn-symbol t "process-~a" name) (process)
     (,(misc:format-fn-symbol 'sb-ext "process-~a" name) process)))

(gen-process-stream output)

(gen-process-stream input)

(gen-process-stream error)

(defun open-with-editor (file)
  (multiple-value-bind (exe args)
      (external-editor)
    (let ((actual-args (if args
                           (text-utils:split-words args)
                           nil)))
      (run-external-program exe
                            (append actual-args
                                    (list file))
                            :search t
                            :wait   t
                            :input  t
                            :output t
                            :error  t))))

(defun exit-program (&optional (exit-code 0))
  (uiop:quit exit-code))

(defun user-cache-dir (&rest more)
  (fs:pathname->namestring (apply #'uiop:xdg-cache-home
                                  (append (list +program-name+) more))))

(defun cached-file-path (filename)
  (text-utils:strcat (user-cache-dir) fs:*directory-sep* filename))

(defun generate-ssl-certificate (outdir)
  (let* ((cert-file (text-utils:strcat outdir fs:*directory-sep* +ssl-cert-name+))
         (key-file  (text-utils:strcat outdir fs:*directory-sep* +ssl-key-name+))
         (cmd-args  (format nil
                            (text-utils:strcat "req -new -nodes -x509 -days 365 -subj / "
                                               "-keyout ~a -outform PEM -out ~a")
                            key-file
                            cert-file)))
    (run-external-program +openssl-bin+
                          (text-utils:split-words cmd-args)
                          :output nil
                          :error  :output)
    (values cert-file key-file)))

(defun change-ssl-key-passphrase (keypath old-passphrase new-passphrase)
  (fs:with-anaphoric-temp-file (stream :unlink t)
    (with-input-from-string (passphrase-stream new-passphrase)
      (let* ((cmd-args (format nil
                               (text-utils:strcat "rsa -aes256 -in ~a -out ~a"
                                                  " -passin pass:~a -passout stdin")
                               keypath
                               fs:temp-file
                               old-passphrase
                               new-passphrase)))
        (let ((output-string (misc:make-fresh-array 0 #\a 'character nil)))
          (with-output-to-string (output-stream output-string)
            (let ((process (run-external-program +openssl-bin+
                                                 (text-utils:split-words cmd-args)
                                                 :input  passphrase-stream
                                                 :output output-stream
                                                 :error  :output
                                                 :wait t)))
              (if (process-exit-success-p process)
                  (fs:copy-a-file fs:temp-file keypath :overwrite t)
                  (error "error changing passphrase for key ~a ~a"
                         keypath
                         output-string)))))))))

(defun ssl-key-has-empty-password-p (key-path)
  (with-input-from-string (passphrase-stream (format nil "~%"))
    (let* ((cmd-args (format nil "rsa -passin stdin -noout -text -in ~a" key-path))
           (process (run-external-program +openssl-bin+
                                          (text-utils:split-words cmd-args)
                                          :input  passphrase-stream
                                          :output nil
                                          :error  nil
                                          :wait t)))
      (process-exit-success-p process))))

(defun send-to-pipe (data program-and-args)
  (croatoan:end-screen)
  (with-input-from-string (stream data)
    (let ((command-line-splitted (text-utils:split-words program-and-args)))
      (run-external-program (first command-line-splitted)
                            (rest command-line-splitted)
                            :search t
                            :wait   t
                            :input  stream
                            :output t
                            :error  t))))

(defun open-link-with-program (program-and-args link &key (wait nil))
  (let* ((command-line-splitted (text-utils:split-words program-and-args))
         (program               (first command-line-splitted))
         (args                  (append (rest command-line-splitted)
                                        (list link))))
    (run-external-program program
                          args
                          :search t
                          :wait   wait
                          :output nil
                          :error  :output)))

(defun open-resource-with-external-program (resource give-focus-to-message-window
                                            &key (open-for-edit nil))
  (flet ((edit (file)
           (croatoan:end-screen)
           (os-utils:open-with-editor file)))
    (alexandria::when-let* ((parsed-as-iri      (iri:iri-parse resource :null-on-error t))
                            (parsed-no-fragment (iri:remove-fragment parsed-as-iri)))
      (let ((program  (if (iri:absolute-url-p resource)
                          (swconf:link-regex->program-to-use (text-utils:to-s parsed-no-fragment))
                          (swconf:link-regex->program-to-use resource))))
        (if program
            (cond
              ((swconf:use-editor-as-external-program-p program)
               (edit resource))
              ((swconf:use-tinmop-as-external-program-p program)
               (if open-for-edit
                   (edit resource)
                   (gemini-viewer:load-gemini-url resource
                                                  :give-focus-to-message-window
                                                  give-focus-to-message-window)))
              (t
               (os-utils:open-link-with-program program resource :wait open-for-edit)))
            (if open-for-edit
                (error (_ "No program defined in configuration file to edit this kind of files"))
                (os-utils:xdg-open resource)))))))

(defun open-resource-with-tinmop-p (resource)
  (alexandria:when-let ((program (swconf:link-regex->program-to-use resource)))
    (swconf:use-tinmop-as-external-program-p program)))

(defgeneric file->mime-type (object))

(defmethod file->mime-type ((object string))
  (let ((process (run-external-program +file-bin+
                                       (list "-E" "--mime-type" "--brief" object)
                                       :search t
                                       :wait   t
                                       :output :stream
                                       :error  nil)))
    (if (process-exit-success-p process)
        (text-utils:trim-blanks (read-line (process-output-stream process)))
        nil)))

(defmethod file->mime-type ((object pathname))
  (file->mime-type (fs:pathname->namestring object)))

(defun unzip-file (zip-file destination-dir)
  (cond
    ((not (fs:file-exists-p zip-file))
     (error (format nil (_ "File ~s does not exists"))))
    ((not (fs:directory-exists-p destination-dir))
     (error (format nil (_ "Destination directory ~s does not exists"))))
    (t
     (run-external-program +unzip-bin+
                           (list "-o" zip-file "-d" destination-dir)
                           :search t
                           :wait   t
                           :output nil
                           :error  :output))))

(defun unzip-single-file (zip-file file-entry)
  (with-output-to-string (stream)
    (let* ((process (run-external-program +unzip-bin+
                                          (list "-p" zip-file file-entry)
                                          :search t
                                          :wait   t
                                          :output stream
                                          :error  :output)))
      (when (not (process-exit-success-p process))
        (error (format nil (_ "File ~s extraction from ~s failed") file-entry zip-file))))))

(defun copy-to-clipboard (text)
  (trivial-clipboard:text text))