lisp/genpass.lisp @ 5f30a4963a1c

(eval-when (:compile-toplevel :load-toplevel :execute)
  (ql:quickload '(:adopt :series :iterate :str) :silent t))

(defpackage :genpass
  (:use :cl :iterate)
  (:export :toplevel :*ui*))

(in-package :genpass)

;;;; Functionality ------------------------------------------------------------
(defparameter *passphrase-sep* " ")
(defparameter *words* nil)

(defmacro -<> (value &body forms)
  (reduce (lambda (val expression)
            (subst val '<> expression))
          forms
          :initial-value value))

(defun safep (char)
  (or (char<= #\a char #\z)
      (char<= #\A char #\Z)
      (char<= #\0 char #\9)))

(defun word-list ()
  (unless *words*
    (setf *words*
          (iterate
            (for line :in-file "/usr/share/dict/words" :using #'read-line)
            (when (every #'safep line)
              (collect line :result-type vector)))))
  *words*)

(defun random-unsigned-byte-32 ()
  (with-open-file (urandom "/dev/urandom" :element-type '(unsigned-byte 8))
    (logior (ash (read-byte urandom) 0)
            (ash (read-byte urandom) 8)
            (ash (read-byte urandom) 16)
            (ash (read-byte urandom) 24))))

(defun urandom (limit)
  (check-type limit (integer 0 (#.(expt 2 32))))
  (iterate
    (with threshold = (mod (expt 2 32) limit))
    (for candidate = (random-unsigned-byte-32))
    (finding (mod candidate limit) :such-that (>= candidate threshold))))

(defun random-elt (sequence)
  (elt sequence (urandom (length sequence))))

(defun random-words (n)
  (iterate
    (with words = (word-list))
    (repeat n)
    (collect (random-elt words))))

(defun random-sentence% (words)
  (str:join *passphrase-sep* (mapcar #'string-capitalize (random-words words))))

(defun random-sentence (words length)
  (iterate
    (for candidate = (random-sentence% words))
    (finding candidate :such-that (<= (length candidate) length))))

(defun random-garbage (length)
  (with-open-file (urandom "/dev/urandom" :element-type '(unsigned-byte 8))
    (-<> urandom
      (series:scan-stream <> #'read-byte)
      (series:map-fn t #'code-char <>)
      (series:choose-if #'safep <>)
      (series:subseries <> 0 length)
      (series:collect 'string <>))))

(defun random-smart (words length)
  (check-type words (integer 1))
  (format nil "~A~A~D"
          (random-sentence words (- length 1 (length *passphrase-sep*)))
          *passphrase-sep*
          (urandom 10)))


;;;; Run ----------------------------------------------------------------------
(defun run (length words smart smush?)
  (let ((*passphrase-sep* (if smush? "" " ")))
    (write-string
      (cond
        ((zerop words) (random-garbage length))
        (smart (random-smart words length))
        (t (random-sentence words length))))))


;;;; User Interface -----------------------------------------------------------
(defparameter *examples*
  '(("Generate a random passphrase no longer than 24 characters:"
     . "genpass --length 24")
    ("Generate a more random, harder to type password:"
     . "genpass --no-words")
    ("Generate a six word passphrase with no spaces:"
     . "genpass --words 6 --smush")))


(defparameter *help*
  (adopt:make-option 'help
    :help "Display help and exit."
    :long "help"
    :short #\h
    :reduce (constantly t)))

(defparameter *length*
  (adopt:make-option 'length
    :help "Ensure password is no longer than N characters (default 40)."
    :long "length"
    :short #\l
    :parameter "N"
    :initial-value 40
    :reduce #'adopt:newest
    :key #'parse-integer))

(defparameter *words*
  (adopt:make-option 'words
    :help "If non-zero, generate passphrases of N words instead of opaque strings (default 4)."
    :long "words"
    :short #\w
    :parameter "N"
    :initial-value 4
    :reduce #'adopt:newest
    :key #'parse-integer))

(defparameter *no-words*
  (adopt:make-option 'no-words
    :result-key 'words
    :help "Shorthand for --words=0."
    :long "no-words"
    :short #\W
    :reduce (constantly 0)))

(defparameter *smart*
  (adopt:make-option 'smart
    :help "Smart mode (the default).  Generate as with --words, but add a number on the end to satisfy the red tape on many sites."
    :long "smart"
    :short #\s
    :initial-value t
    :reduce (constantly t)))

(defparameter *no-smart*
  (adopt:make-option 'no-smart
    :result-key 'smart
    :help "Turn off smart mode."
    :long "no-smart"
    :short #\S
    :reduce (constantly nil)))

(defparameter *smush*
  (adopt:make-option 'smush
    :help "Don't include spaces in passphrases."
    :long "smush"
    :short #\m
    :reduce (constantly t)))

(defparameter *no-smush*
  (adopt:make-option 'no-smush :result-key 'smush
    :help "Include spaces in passphrases (the default)."
    :long "no-smush"
    :short #\M
    :reduce (constantly nil)))


(defparameter *password-options*
  (adopt:make-group 'password-options
    :title "Password Options"
    :help "The format of generated passwords can be customized in a number of ways."
    :options (list *length*
                   *words* *no-words*
                   *smart* *no-smart*
                   *smush* *no-smush*)))


(defparameter *ui*
  (adopt:make-interface
    :name "genpass"
    :usage "[OPTIONS]"
    :summary "Generate a random password."
    :help "Generate a random password."
    :examples *examples*
    :contents (list *help* *password-options*)))


(defun toplevel ()
  (handler-case
      (multiple-value-bind (arguments options) (adopt:parse-options *ui*)
        (when (gethash 'help options)
          (adopt:print-help-and-exit *ui*))
        (when arguments
          (error "Unrecognized command line arguments: ~S" arguments))
        (run (gethash 'length options)
             (gethash 'words options)
             (gethash 'smart options)
             (gethash 'smush options)))
    (error (c) (adopt:print-error-and-exit c))))