lisp/genpass.lisp @ 52107888f30a

(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 -----------------------------------------------------------
(adopt:define-string *documentation*
  "Generate a random password.")

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

(adopt:define-interface *ui*
    (:name "genpass"
     :usage "[OPTIONS]"
     :summary "Generate a random password."
     :documentation *documentation*
     :examples *examples*)
  ((help)
   :documentation "Display help and exit."
   :long "help"
   :short #\h
   :reduce (constantly t))
  ((length)
   :documentation "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)
  ((words)
   :documentation "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)
  ((no-words words)
   :documentation "Shorthand for --words=0."
   :long "no-words"
   :short #\W
   :reduce (constantly 0))
  ((smart)
   :documentation "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))
  ((no-smart smart)
   :documentation "Turn off smart mode."
   :long "no-smart"
   :short #\S
   :reduce (constantly nil))
  ((smush)
   :documentation "Don't include spaces in passphrases."
   :long "smush"
   :short #\m
   :reduce (constantly t))
  ((no-smush smush)
   :documentation "Include spaces in passphrases (the default)."
   :long "no-smush"
   :short #\M
   :reduce (constantly nil)))

(defun toplevel ()
  (handler-case
      (multiple-value-bind (arguments options) (adopt:parse-options *ui*)
        (when (gethash 'help options)
          (adopt:print-usage-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))))