git.chise.org Git - elisp/gnus.git-/blob - contrib/passwd.el

   1 ;;; passwd.el --- Prompting for passwords semi-securely
   2
   3 ;; Copyright (C) 1994 Free Software Foundation, Inc.
   4 ;; Keywords: comm, extensions
   5
   6 ;; Author: Jamie Zawinski <jwz@netscape.com>
   7
   8 ;; This file is part of XEmacs.
   9
  10 ;; XEmacs is free software; you can redistribute it and/or modify it
  11 ;; under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; XEmacs is distributed in the hope that it will be useful, but
  16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19
  20 ;;; Synched up with: Not in FSF.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  24 ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  25
  26 ;;; Change Log:
  27 ;;
  28 ;;  Sun Jun 12 04:19:30 1994 by sandy on ibm550.sissa.it
  29 ;;    Added support for password histories and (provide 'passwd)
  30 ;;    (jwz says: this "history" thing is completely undocumented, you loser!)
  31 ;; 2-Jan-95 (mon); 4:13 AM by jwz@netscape.com
  32 ;;    Fixed Sandy's extreme keymap bogosity.  Made it invert the screen when
  33 ;;    reading securely (this could be better; maybe use red text or something
  34 ;;    instead...)
  35 ;; 9-Jul-95 (fri); 4:55 AM by jwz@netscape.com
  36 ;;    Made it work with XEmacs 19.12.
  37 ;; 7-Jul-95 by cthomp@cs.uiuc.edu
  38 ;;    Added variable to control inverting frame when keyboard grabbed
  39
  40 ;;; Code:
  41
  42 (defvar passwd-invert-frame-when-keyboard-grabbed t
  43   "*If non-nil swap the foreground and background colors of all faces.
  44 This is done while the keyboard is grabbed in order to give a visual
  45 clue that a grab is in effect.")
  46
  47 (defvar passwd-echo ?.
  48   "*The character which should be echoed when typing a password,
  49 or nil, meaning echo nothing.")
  50
  51 (defvar read-passwd-map
  52   (let ((i 0)
  53         (s (make-string 1 0))
  54         map)
  55     (cond ((fboundp 'set-keymap-parent)
  56            (setq map (make-keymap))
  57            (set-keymap-parent map minibuffer-local-map))
  58           (t  ; v18/FSFmacs compatibility
  59            (setq map (copy-keymap minibuffer-local-map))))
  60     (if (fboundp 'set-keymap-name)
  61         (set-keymap-name map 'read-passwd-map))
  62
  63     (while (< i 127)
  64       (aset s 0 i)
  65       (or (and (boundp 'meta-prefix-char) (eq i meta-prefix-char))
  66           (define-key map s 'self-insert-command))
  67       (setq i (1+ i)))
  68
  69     (define-key map "\C-g" 'keyboard-quit)
  70     (define-key map "\C-h" 'delete-backward-char)
  71     (define-key map "\r" 'exit-minibuffer)
  72     (define-key map "\n" 'exit-minibuffer)
  73     (define-key map "\C-u" 'passwd-erase-buffer)
  74     (define-key map "\C-q" 'quoted-insert)
  75     (define-key map "\177" 'delete-backward-char)
  76     (define-key map "\M-n" 'passwd-next-history-element)
  77     (define-key map "\M-p" 'passwd-previous-history-element)
  78     map)
  79   "Keymap used for reading passwords in the minibuffer.
  80 The \"bindings\" in this map are not real commands; only a limited
  81 number of commands are understood.  The important bindings are:
  82 \\<read-passwd-map>
  83         \\[passwd-erase-buffer] Erase all input.
  84         \\[quoted-insert]       Insert the next character literally.
  85         \\[delete-backward-char]        Delete the previous character.
  86         \\[exit-minibuffer]     Accept what you have typed.
  87         \\[keyboard-quit]       Abort the command.
  88
  89 All other characters insert themselves (but do not echo.)")
  90
  91 ;;; internal variables
  92
  93 (defvar passwd-history nil)
  94 (defvar passwd-history-posn 0)
  95
  96 ;;;###autoload
  97 (defun read-passwd (prompt &optional confirm default)
  98   "Prompts for a password in the minibuffer, and returns it as a string.
  99 If PROMPT may be a prompt string or an alist of elements
 100 '\(prompt . default\).
 101 If optional arg CONFIRM is true, then ask the user to type the password
 102 again to confirm that they typed it correctly.
 103 If optional arg DEFAULT is provided, then it is a string to insert as
 104 the default choice (it is not, of course, displayed.)
 105
 106 If running under X, the keyboard will be grabbed (with XGrabKeyboard())
 107 to reduce the possibility that evesdropping is occuring.
 108
 109 When reading a password, all keys self-insert, except for:
 110 \\<read-passwd-map>
 111         \\[read-passwd-erase-line]      Erase the entire line.
 112         \\[quoted-insert]       Insert the next character literally.
 113         \\[delete-backward-char]        Delete the previous character.
 114         \\[exit-minibuffer]     Accept what you have typed.
 115         \\[keyboard-quit]       Abort the command.
 116
 117 The returned value is always a newly-created string.  No additional copies
 118 of the password remain after this function has returned.
 119
 120 NOTE: unless great care is taken, the typed password will exist in plaintext
 121 form in the running image for an arbitrarily long time.  Priveleged users may
 122 be able to extract it from memory.  If emacs crashes, it may appear in the
 123 resultant core file.
 124
 125 Some steps you can take to prevent the password from being copied around:
 126
 127  - as soon as you are done with the returned string, destroy it with
 128    (fillarray string 0).  The same goes for any default passwords
 129    or password histories.
 130
 131  - do not copy the string, as with concat or substring - if you do, be
 132    sure to keep track of and destroy all copies.
 133
 134  - do not insert the password into a buffer - if you do, be sure to
 135    overwrite the buffer text before killing it, as with the functions
 136    `passwd-erase-buffer' or `passwd-kill-buffer'.  Note that deleting
 137    the text from the buffer does NOT necessarily remove the text from
 138    memory.
 139
 140  - be careful of the undo history - if you insert the password into a
 141    buffer which has undo recording turned on, the password will be
 142    copied onto the undo list, and thus recoverable.
 143
 144  - do not pass it as an argument to a shell command - anyone will be
 145    able to see it if they run `ps' at the right time.
 146
 147 Note that the password will be temporarily recoverable with the `view-lossage'
 148 command.  This data will not be overwritten until another hundred or so
 149 characters are typed.  There's not currently a way around this."
 150
 151   (save-excursion
 152     (let ((input (get-buffer-create " *password*"))
 153           (passwd-history-posn 0)
 154           passwd-history)
 155       (if (listp prompt)
 156           (setq passwd-history prompt
 157                 default (cdr (car passwd-history))))
 158       (set-buffer input)
 159       (buffer-disable-undo input)
 160       (use-local-map read-passwd-map)
 161       (unwind-protect
 162           (progn
 163             (if (passwd-grab-keyboard)
 164                 (passwd-secure-display))
 165             (read-passwd-1 input prompt nil default)
 166             (set-buffer input)
 167
 168             (if (not confirm)
 169                 (buffer-string)
 170               (let ((ok nil)
 171                     passwd)
 172                 (while (not ok)
 173                   (set-buffer input)
 174                   (setq passwd (buffer-string))
 175                   (read-passwd-1 input prompt "[Retype to confirm]")
 176                   (if (passwd-compare-string-to-buffer passwd input)
 177                       (setq ok t)
 178                     (fillarray passwd 0)
 179                     (setq passwd nil)
 180                     (beep)
 181                     (read-passwd-1 input prompt "[Mismatch. Start over]")
 182                     ))
 183                 passwd)))
 184         ;; protected
 185         (passwd-ungrab-keyboard)
 186         (passwd-insecure-display)
 187         (passwd-kill-buffer input)
 188         (if (fboundp 'clear-message) ;XEmacs
 189             (clear-message)
 190           (message ""))
 191         ))))
 192
 193
 194 (defun read-passwd-1 (buffer prompt &optional prompt2 default)
 195   (set-buffer buffer)
 196   (passwd-erase-buffer)
 197   (if default (insert default))
 198   (catch 'exit ; exit-minibuffer throws here
 199     (while t
 200       (set-buffer buffer)
 201       (let* ((minibuffer-completion-table nil)
 202              (cursor-in-echo-area t)
 203              (echo-keystrokes 0)
 204              (key (passwd-read-key-sequence
 205                    (concat (if (listp prompt)
 206                                (car (nth passwd-history-posn passwd-history))
 207                              prompt)
 208                            prompt2
 209                            (if passwd-echo
 210                                (make-string (buffer-size) passwd-echo)))))
 211              (binding (key-binding key)))
 212         (setq prompt2 nil)
 213         (set-buffer buffer)             ; just in case...
 214         (if (fboundp 'event-to-character) ;; lemacs
 215             (setq last-command-event (aref key (1- (length key)))
 216                   last-command-char (event-to-character last-command-event))
 217           ;; v18/FSFmacs compatibility
 218           (setq last-command-char (aref key (1- (length key)))))
 219         (setq this-command binding)
 220         (condition-case c
 221             (command-execute binding)
 222           (error
 223            (beep)
 224            (if (fboundp 'display-error)
 225                (display-error c t)
 226              ;; v18/FSFmacs compatibility
 227              (message (concat (or (get (car-safe c) 'error-message) "???")
 228                               (if (cdr-safe c) ": ")
 229                               (mapconcat
 230                                (function (lambda (x) (format "%s" x)))
 231                                (cdr-safe c) ", "))))
 232            (sit-for 2)))
 233         ))))
 234
 235 (defun passwd-previous-history-element (n)
 236   (interactive "p")
 237   (or passwd-history
 238       (error "Password history is empty."))
 239   (let ((l (length passwd-history)))
 240     (setq passwd-history-posn
 241           (% (+ n passwd-history-posn) l))
 242     (if (< passwd-history-posn 0)
 243         (setq passwd-history-posn (+ passwd-history-posn l))))
 244   (let ((obuff (current-buffer))) ; want to move point in passwd buffer
 245     (unwind-protect
 246         (progn
 247           (set-buffer " *password*")
 248           (passwd-erase-buffer)
 249           (insert (cdr (nth passwd-history-posn passwd-history))))
 250       (set-buffer obuff))))
 251
 252 (defun passwd-next-history-element (n)
 253   (interactive "p")
 254   (passwd-previous-history-element (- n)))
 255
 256 (defun passwd-erase-buffer ()
 257   ;; First erase the buffer, which will simply enlarge the gap.
 258   ;; Then insert null characters until the gap is filled with them
 259   ;; to prevent the old text from being visible in core files or kmem.
 260   ;; (Actually use 3x the size of the buffer just to be safe - a longer
 261   ;; passwd might have been typed and backspaced over.)
 262   (interactive)
 263   (widen)
 264   (let ((s (* (buffer-size) 3)))
 265     (erase-buffer)
 266     (while (> s 0)
 267       (insert ?\000)
 268       (setq s (1- s)))
 269     (erase-buffer)))
 270
 271 (defun passwd-kill-buffer (buffer)
 272   (save-excursion
 273     (set-buffer buffer)
 274     (buffer-disable-undo buffer)
 275     (passwd-erase-buffer)
 276     (set-buffer-modified-p nil))
 277   (kill-buffer buffer))
 278
 279
 280 (defun passwd-compare-string-to-buffer (string buffer)
 281   ;; same as (equal string (buffer-string)) but with no dangerous consing.
 282   (save-excursion
 283     (set-buffer buffer)
 284     (goto-char (point-min))
 285     (let ((L (length string))
 286           (i 0))
 287       (if (/= L (- (point-max) (point-min)))
 288           nil
 289         (while (not (eobp))
 290           (if (/= (following-char) (aref string i))
 291               (goto-char (point-max))
 292             (setq i (1+ i))
 293             (forward-char)))
 294         (= (point) (+ i (point-min)))))))
 295
 296
 297 (defvar passwd-face-data nil)
 298 (defun passwd-secure-display ()
 299   ;; Inverts the screen - used to indicate secure input, like xterm.
 300   (cond
 301    ((and passwd-invert-frame-when-keyboard-grabbed
 302          (fboundp 'set-face-foreground))
 303     (setq passwd-face-data
 304           (delq nil (mapcar (function
 305                              (lambda (face)
 306                                (let ((fg (face-foreground face))
 307                                      (bg (face-background face)))
 308                                  (if (or fg bg)
 309                                      (if (fboundp 'color-name)
 310                                          (list face
 311                                                (color-name fg)
 312                                                (color-name bg))
 313                                        (list face fg bg))
 314                                    nil))))
 315                             (if (fboundp 'list-faces)
 316                                 (list-faces) ; lemacs
 317                               (face-list)    ; FSFmacs
 318                               ))))
 319     (let ((rest passwd-face-data))
 320       (while rest
 321         (set-face-foreground (nth 0 (car rest)) (nth 2 (car rest)))
 322         (set-face-background (nth 0 (car rest)) (nth 1 (car rest)))
 323         (setq rest (cdr rest))))))
 324   nil)
 325
 326 (defun passwd-insecure-display ()
 327   ;; Undoes the effect of `passwd-secure-display'.
 328   (cond
 329    (passwd-invert-frame-when-keyboard-grabbed
 330     (while passwd-face-data
 331       (set-face-foreground (nth 0 (car passwd-face-data))
 332                            (nth 1 (car passwd-face-data)))
 333       (set-face-background (nth 0 (car passwd-face-data))
 334                            (nth 2 (car passwd-face-data)))
 335       (setq passwd-face-data (cdr passwd-face-data)))
 336     nil)))
 337
 338 (defun passwd-grab-keyboard ()
 339   (cond ((not (and (fboundp 'x-grab-keyboard) ; lemacs 19.10+
 340                    (eq 'x (if (fboundp 'frame-type)
 341                               (frame-type (selected-frame))
 342                             (live-screen-p (selected-screen))))))
 343          nil)
 344         ((x-grab-keyboard)
 345          t)
 346         (t
 347          (message "Unable to grab keyboard - waiting a second...")
 348          (sleep-for 1)
 349          (cond ((x-grab-keyboard)
 350                 (message "Keyboard grabbed on second try.")
 351                 t)
 352                (t
 353                 (beep)
 354                 (message "WARNING: keyboard is insecure (unable to grab!)")
 355                 (sleep-for 3)
 356                 nil)))))
 357
 358 (defun passwd-ungrab-keyboard ()
 359   (if (and (fboundp 'x-ungrab-keyboard) ; lemacs 19.10+
 360            (eq 'x (if (fboundp 'frame-type)
 361                       (frame-type (selected-frame))
 362                     (live-screen-p (selected-screen)))))
 363       (x-ungrab-keyboard)))
 364
 365 ;; v18 compatibility
 366 (or (fboundp 'buffer-disable-undo)
 367     (fset 'buffer-disable-undo 'buffer-flush-undo))
 368
 369 ;; read-key-sequence echoes the key sequence in Emacs 18.
 370 (defun passwd-read-key-sequence (prompt)
 371   (let ((inhibit-quit t)
 372         str)
 373     (while (or (null str) (keymapp (key-binding str)))
 374       (if (fboundp 'display-message)
 375           (display-message 'prompt prompt)
 376         (message prompt))
 377       (setq str (concat str (char-to-string (read-char)))))
 378     (setq quit-flag nil)
 379     str))
 380
 381 (or (string-match "^18" emacs-version)
 382     (fset 'passwd-read-key-sequence 'read-key-sequence))
 383
 384 (provide 'passwd)
 385
 386 ;;; passwd.el ends here