Quick Password Generator.

qpg-mode.el

;;; qpg-mode.el -- Quick Password Generator.
;; Copyright (C) 2017, 2018, 2020, 2022, 2023 fubuki

;; Author: fubuki at frill.org
;; Keywords: tools
;; Version: $Revision: 1.25 $

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

;; 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 GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; Quick Password Generator.

;;; Installation:

;; (require 'qpg-mode)

;;; Code:
(require 'cl-lib)
(require 'epg)

(defgroup qpg-mode nil
  "Quick Password Generator."
  :group   'applications
  :version "25.3")

(defcustom qpg-default-length 24
  "qpg default password length."
  :type  'integer
  :group 'qpg-mode)

(defcustom qpg-max-length 256
  "qpg password max length."
  :type  'integer
  :group 'qpg-mode)

(make-obsolete-variable
 'qpg-default-master-file-name 'qpg-master-file-name "Changed name.")
(defcustom qpg-master-file-name nil
  "qpg default master file name."
  :type  '(coice file (const nil))
  :group 'qpg-mode)

;;; (defcustom qpg-2-way-save nil
;;;   "qpg master and single file flag."
;;;   :type 'boolean
;;;   :group 'qpg-mode)

(defcustom qpg-prepend t
  "qpg master file append mode."
  :type 'boolean
  :group 'qpg-mode)

(defcustom qpg-default-extention ".gpg"
  "Default file extension."
  :type  'string
  :group 'qpg-mode)

(defcustom qpg-auto-new-name nil
  "qpg auto new name."
  :type  'boolean
  :group 'qpg-mode)

(defcustom qpg-format-time-string "%Y%m%d%H%M%S"
  "qpg format time string."
  :type  'string
  :group 'qpg-mode)

(defcustom qpg-default-file-name
  (concat
   "~/qpg-"
   (format-time-string qpg-format-time-string)
   qpg-default-extention)
  "qpg default file name."
  :type  'file
  :group 'qpg-mode)

(make-obsolete-variable
 'qpg-default-directory "`qpg-default-file-name' で合わせて指定." "$Revison")
(defcustom qpg-default-directory (file-name-directory qpg-default-file-name)
  "Default data output directory."
  :type  '(choice directory (const nil))
  :group 'qpg-mode)
  
(defcustom qpg-pass-string-table-default
  '(("0123456789"               . 20)
    ("ABCDEFGHJKLMNPQRSTUVWXYZ" . 20)
    ("abcdefhijkmnprstuvwxyz"   . 60))
  "string or string alist \(cons string percentage)."
  ;; パーセンテージの合計が 100 を越えていても構わないが溢れた分は使われない.
  ;; パスキャラは値の低いテーブルから指定パーセント分ずつ使われていく.
  ;; 100% に達っした時点で指定の長さのパスが完成するので溢れた分は捨てられる事になる.
  :type  '(choice string (repeat (choice string (cons string integer))))
  :group 'qpg-mode)

(defcustom qpg-backup  make-backup-files
  "qpg backup file flag."
  :type  'boolean
  :group 'qpg-mode)

(defcustom qpg-prompt-list '((:pass . "PW: ") (:url . "UR: ") (:id . "ID: "))
  "qpg header tags."
  :type  '(list string)
  :group 'qpg-mode)

(make-obsolete-variable 'qpg-pass-word 'qpg-prompt-list "1.19")
(defcustom qpg-pass-word (cdr (assq :pass  qpg-prompt-list))
  "qpg password header."
  :type 'string
  :group 'qpg-mode)

(make-obsolete-variable 'qpg-url-word 'qpg-prompt-list "1.19")
(defcustom qpg-url-word (cdr (assq :url qpg-prompt-list))
  "qpg URL header."
  :type 'string
  :group 'qpg-mode)

(make-obsolete-variable 'qpg-id-word 'qpg-prompt-list "1.19")
(defcustom qpg-id-word (cdr (assq :id qpg-prompt-list))
  "qpg ID header."
  :type 'string
  :group 'qpg-mode)

(defcustom qpg-mode-font-lock
  `((,(rx bol (or ";" "#") (+ any) eol) . 'dired-ignored)
    (,(rx bol (+ any) ": ") . font-lock-type-face)
    (,(rx (or "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun")
          space
          (or "Jan" "Feb" "Mar" "Apr" "May" "Jun"
              "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")
          space
          (and (or space digit) digit)
          space
          (and digit digit ":" digit digit ":" digit digit)
          space
          (= 4 digit))
     . font-lock-keyword-face))
  "qpg-mode font loack regexp."
  :type  '(repeat
	   (choice (cons :tag "cons" regexp face)
		   (list :tag "list" regexp integer face)
		   regexp))
  :group 'qpg-mode)

;; (defvar qpg-mode-blind-map
;;   (let ((menu (make-sparse-keymap "qpg-blind")))
;;     (define-key menu [qpg-show]
;;                 '("Show" . qpg-show))
;;     (define-key menu [qpg-hide]
;;                 '("Hide" . qpg-hide))
;;     menu))

(defvar qpg-buff-name "*Quick Password Generator*")

(defvar qpg-pop-action
  '((display-buffer-at-bottom
     display-buffer-below-selected)
    (window-height . fit-window-to-buffer)))

(defun qpg-get-default-table ()
  (if (consp qpg-pass-string-table-default)
      (copy-alist qpg-pass-string-table-default)
    (list (cons qpg-pass-string-table-default 100))))

(defvar qpg-pass-string-table (qpg-get-default-table) "Work.")

(defvar-local qpg-table-his nil "Work.")
(defvar-local qpg-table-def nil "alist Work.")

(defvar qpg-mode-map
  (let ((map  (make-sparse-keymap))
        (menu (make-sparse-keymap "qpg")))
    (define-key map [remap move-beginning-of-line] 'qpg-beginning-of-line)
    (define-key map [remap move-end-of-line] 'qpg-end-of-line)
    (define-key map "\C-c\C-c" 'qpg-commit-and-quit)
    (define-key map "\C-c\C-k" 'qpg-cancel)
    (define-key map "\C-c\C-q" 'qpg-cancel)
    ;; (define-key map [?\e ?\e]  'qpg-cancel)
    (define-key map "\C-c\C-n" 'qpg-new-name)
    (define-key map "\C-c\C-g" 'qpg-re-generate)
    (define-key map "\C-l"     'qpg-re-generate-ask)
    (define-key map "\C-c\C-l" 'qpg-length)
    (define-key map "\C-c\C-a" 'qpg-add-table)
    (define-key map "\C-c\C-r" 'qpg-remove-table)
    (define-key map "\C-c\C-i" 'qpg-init-table)
    (define-key map "\C-c\C-w" 'qpg-pass-to-kill-ring)
    (define-key map "\C-c\C-h" 'qpg-hide)
    (define-key map "\C-c\C-s" 'qpg-show)
    (define-key map "\C-\M-l"  'recenter-top-bottom)
    (define-key map [menu-bar qpg] (cons "QPG" menu))
    (define-key menu [qpg-pass-to-kill-ring]
                '("Copy to Kill Ring" . qpg-pass-to-kill-ring))
    (define-key menu [qpg-new-name]
                '("New name" . qpg-new-name))
    ;;     (define-key menu [qpg-blind]
    ;;                 `(menu-item "Blind Star" ,qpg-mode-blind-map))
    (define-key menu [qpg-re-generate]
                '("ReGenerate" . qpg-re-generate))
    (define-key menu [qpg-length]
                '("Pass Length" . qpg-length))
    (define-key menu [qpg-init-table]
                '("PassTable init." . qpg-init-table))
    (define-key menu [qpg-remove-table]
                '("Remove PassTable" . qpg-remove-table))
    (define-key menu [qpg-add-table]
                '("Add PassTable" . qpg-add-table))
    (define-key menu [qpg-commit-and-quit]
                '("Commit & Quit" . qpg-commit-and-quit))
    (define-key menu [qpg-cancel]
                '("Cancel" . qpg-cancel))
    map))

(defun qpg (&optional prefix)
  "Quick Password Generator command.
PREFIX no-master mode."
  (interactive "P")
  (let ((qpg-master-file-name (if prefix nil qpg-master-file-name))
        buff)
    (setq buff (get-buffer-create qpg-buff-name))
    (set-buffer buff)
    (erase-buffer)
    (qpg-mode)
    (random t)
    (insert (format
             "%s\n%s\n%s\n%s" 
             (current-time-string)
             (cdr (assq :url  qpg-prompt-list))
             (cdr (assq :id   qpg-prompt-list))
             (cdr (assq :pass qpg-prompt-list))))
    (qpg-re-generate)
    (goto-char (point-min))
    (re-search-forward (cdr (assq :url qpg-prompt-list)))
    (set-buffer-modified-p nil)
    (buffer-disable-undo)
    (buffer-enable-undo)
    (pop-to-buffer buff qpg-pop-action)))

(defun qpg-beginning-of-line ()
  (interactive)
  (let ((pos (point)))
    (if (eq pos (line-beginning-position))
        nil
      (beginning-of-line)
      (and (re-search-forward ".+: " (line-end-position) t)
           (eq pos (point))
           (beginning-of-line)))))

(defun qpg-end-of-line ()
  (interactive)
  (if (eq (point) (line-end-position))
      nil
    (or (re-search-forward ".+: " (line-end-position) t)
        (end-of-line))))

(defun qpg-exit ()
  "qpg exit."
  (kill-buffer)
  (delete-window))

(defun qpg-end-of-line-remove-lf ()
  "Delete terminate LF."
  (let ((p (point)))
    (skip-chars-backward "\n")
    (delete-region (point) p)))

(defun qpg-make-backup-file (master backup)
  "Rename MASTER to BACKUP safely and securely."
  (and (file-exists-p master)
       (file-exists-p backup)
       (delete-file backup))
  (when (file-exists-p master)
    (copy-file master backup)
    (delete-file master)))

(defun qpg-write-file (file)
  (let* ((master qpg-master-file-name)
         (string (buffer-substring-no-properties (point-min) (point-max)))
         (backup (make-backup-file-name master))
         (default-directory (or (file-name-directory qpg-default-file-name)
                                default-directory)))
    (cond
     (master
       (with-temp-buffer
         (and (file-exists-p master) (insert-file-contents master))
         (cond
          (qpg-prepend
           (insert string "\n\n"))
          (t
           (goto-char (point-max))
           (qpg-end-of-line-remove-lf)
           (insert "\n\n" string)))
         (qpg-make-backup-file master backup)
         (write-region (point-min) (point-max) master nil 'silent)))
       ;; Continuously `epa-write-region' freezes with encoding and clogging.
       ;; (when qpg-2-way-save
       ;;  (write-region (point-min) (point-max) file nil 'silent)))
    (t
     (write-region (point-min) (point-max) file)))))

(defun qpg-commit-and-quit ()
  "qpg save and quit."
  (interactive)
    (qpg-write-file (if qpg-auto-new-name (qpg-new-name) qpg-default-file-name))
    (qpg-exit))

(defun qpg-cancel ()
  "qpg cancel."
  (interactive)
  (when (y-or-n-p "Cancel?")
    (qpg-exit))
  (message nil))

(defun qpg-pass-to-kill-ring ()
  (interactive)
  (save-excursion
    (goto-char (point-min))
    (when (re-search-forward (concat "^" (cdr (assq :pass qpg-prompt-list))) nil t)
      (kill-new (buffer-substring (match-end 0) (line-end-position)))
      (message "Pass to Kill Ring."))))
  
(defun qpg-length (len)
  "LEN is password length."
  (interactive
   (let* ((def (number-to-string qpg-default-length))
          (len (read-string (format "Length (default %s): " def) nil nil def)))
     (list (string-to-number len))))
  (if (or (> len qpg-max-length) (< len 1))
      (error "Illegal Number")
    (setq qpg-default-length len))
  (qpg-re-generate))

(defun qpg-car-equal (a b)
  (equal (car a) (car b)))

(defun qpg-add-table (string prefix)
  "qpg add password characters.
Percentage specified in the prefix.
10% if omitted."
  (interactive
   (let* ((per    (or (and current-prefix-arg (prefix-numeric-value current-prefix-arg))
                      (if  (car qpg-table-def) (cdar qpg-table-def) 10)))
          (def    (caar qpg-table-def))
          (defstr (if def (format " (default %s)" def) ""))
          (str (read-string (format "PassCharacters%s: " defstr)
                            nil 'qpg-table-his def)))
     (unless (equal def str) (setq per 10))
     (list str per)))
  (add-to-list 'qpg-pass-string-table (cons string prefix) nil #'qpg-car-equal)
  (qpg-re-generate))

(defun qpg-remove-table (string)
  "Remove STRING from `qpg-pass-string-table'."
  (interactive
   (let ((elt
          (completing-read
           "Remove: "
           (mapcar #'(lambda (s) (cons (car s) s)) qpg-pass-string-table))))
     (list elt)))
  (setq qpg-pass-string-table
        (let ((tmp (assoc string qpg-pass-string-table)))
          (add-to-list 'qpg-table-def tmp nil #'qpg-car-equal)
          (delete tmp qpg-pass-string-table)))
  (qpg-re-generate))

(defun qpg-init-table ()
  "qpg password table init."
  (interactive)
  (if (y-or-n-p "Reset Password Table?")
      (progn
        (setq qpg-pass-string-table (qpg-get-default-table))
        (qpg-re-generate))
    (message nil)))

(defun qpg-re-generate-ask ()
  (interactive)
  (and (y-or-n-p "Re generate?") (qpg-re-generate))
  (message nil))

(defun qpg-re-generate ()
  "qpg password generate."
  (interactive)
  (save-excursion
    (goto-char (point-min))
    (re-search-forward (cdr (assq :pass qpg-prompt-list)))
    (delete-region (point) (line-end-position))
    (insert (qpg-pass-string qpg-default-length qpg-pass-string-table))))

(defun qpg-new-name (&optional prefix)
  "qpg new name generate."
  (interactive "P")
  (let ((ext qpg-default-extention)
	(time (format-time-string qpg-format-time-string))
	(regexp (concat
                 "^" (cdr (assq :url qpg-prompt-list))
                 "\\(?1:[ ]*https?://\\)*\\(?2:www.\\)*\\(?3:[^? \n]+\\)"))
        name base)
    (when qpg-auto-new-name
      (save-excursion
	(goto-char (point-min))
	(when (re-search-forward regexp nil t)
	  (setq base (if (match-string 3)
		         (replace-regexp-in-string
                          "[/:~?&<>|]" "_" (match-string 3)))))
	(setq base (if prefix (read-string "Base name: " base) base))))
    (setq name (concat "qpg-" base (and base (not (equal base "")) "-") time ext))
    (message "New File Name: %s" name)
    name))

(defun qpg-shuffle (lst)
  "Shuffle LST back."
  (let (result)
    (random t)
    (while lst
      (push (nth (random (length lst)) lst) result)
      (setq lst (cl-remove (car result) lst :count 1)))
    result))

(defun qpg-actual-length (len table)
  "Expand percentages to actual number of characters."
   (let ((table (if (atom table) (list (cons table 100)) table)))
     (sort
      (mapcar
       #'(lambda (tbl)
           (cons (car tbl) (round (* (/ len 100.0) (cdr tbl)))))
       table)
      #'(lambda (a b) (< (cdr a) (cdr b))))))

(defun qpg-pass-string (len table)
  "Simple password string generator.
    LEN   : Password length.
    TABLE : Password character table list or string."
  (interactive)
  (let ((table (qpg-actual-length len table))
        result)
    (random t)
    (dolist (a table)
      (dotimes (i (cdr a))
        (push (aref (car a) (random (length (car a)))) result)))
    (apply #'string (qpg-shuffle (nthcdr (- (length result) len) result)))))

(define-derived-mode qpg-mode text-mode "QPG"
  "Quick password generator Rev.5
Special Command:
\\{qpg-mode-map}"
  (set (make-local-variable 'font-lock-defaults) (list qpg-mode-font-lock nil)))

(provide 'qpg-mode)
;; fin.