GopherProxy

	pee.scm - pee - Pee a password manager;Pee - because you have to...
	git clone git://vernunftzentrum.de/pee.git
	Log
	Files
	Refs
	LICENSE
	---
	pee.scm (20918B)
	---
	1 ;; Pee - A password manager for the command line
	2 ;;
	3 ;; Copyright (c) 2016 Christian Kellermann <[email protected]>
	4 ;;
	5 ;; Permission to use, copy, modify, and distribute this software for any
	6 ;; purpose with or without fee is hereby granted, provided that the above
	7 ;; copyright notice and this permission notice appear in all copies.
	8 ;;
	9 ;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANT…
	10 ;; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
	11 ;; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE F…
	12 ;; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
	13 ;; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
	14 ;; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT …
	15 ;; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
	16
	17 (include "crypto-helper.scm")
	18
	19 (module pee (main)
	20 (import
	21 scheme
	22 (chicken base)
	23 (chicken condition)
	24 (chicken bitwise)
	25 (chicken io)
	26 (chicken port)
	27 (chicken random)
	28 (chicken format)
	29 (chicken string)
	30 (chicken file)
	31 (chicken pretty-print)
	32 (chicken irregex)
	33 (chicken time)
	34 (chicken pathname)
	35 (chicken process-context)
	36 (chicken sort)
	37 (chicken time posix))
	38
	39 (import
	40 srfi-1
	41 srfi-4
	42 srfi-13
	43 srfi-14
	44 fmt
	45 matchable
	46 tweetnacl
	47 getopt-long
	48 stty
	49 crypto-helper)
	50
	51 (include "program-meta.scm")
	52
	53 (define-constant password-chars "abcdefhijklmnopqrstuvwxyzABCDEFGHIJKLMN…
	54
	55 (include "names.scm")
	56
	57 (define password-modes
	58 '(("all chars" . "")
	59 ("alpha-numeric" . "!@#$%^&*()-=~?/\\|+,:.<>{}[]")
	60 ("easy-to-read" . "l1o0I\|!ji")
	61 ("some-funny-chars" . "\|\\[]{}<>~&")))
	62
	63 (define (entropy-per-char password-chars)
	64 (inexact->exact (floor (* (/ (log (string-length password-chars)) (log…
	65
	66 (define wanted-entropy (* 20 8))
	67
	68 (define (chars-for-mode chars mode)
	69 (char-set->string
	70 (char-set-difference
	71 (string->char-set chars)
	72 (string->char-set mode))))
	73
	74 (define (generate-new-password wanted-entropy mode)
	75 (define (new-indices count)
	76 (let ((password-chars (chars-for-mode password-chars mode)))
	77 (let loop ((len count)
	78 (idx '()))
	79 (clear-line)
	80 (printf "~a/~a random bytes recieved.~!" (- count len) count)
	81 (cond ((zero? len) (clear-line) idx)
	82 (else
	83 (let ((new (filter (lambda (n)
	84 (< n (string-length password-chars)))
	85 (u8vector->list (random-bytes len)))))
	86 (loop (- len (length new)) (append new idx))))))))
	87 (list->string (map (lambda (i)
	88 (string-ref password-chars i))
	89 (new-indices (inexact->exact
	90 (round (/ (* 100 wanted-entropy) (ent…
	91
	92 (define (prompt-for msg #!optional default)
	93 (if default (printf "~a [~a]: " msg default)
	94 (printf "~a: " msg))
	95 (let ((l (read-line)))
	96 (if (and default (equal? "" l))
	97 default
	98 l)))
	99
	100 (define (ask-for-choice msg . options)
	101 (with-stty
	102 '(not echo icanon opost)
	103 (lambda ()
	104 (let loop ()
	105 (clear-line)
	106 (printf "~a [~a]: " msg (apply string-append options))
	107 (let ((answer (string (read-char))))
	108 (cond ((member answer options) =>
	109 (lambda (c)
	110 (clear-line)
	111 (car (string->list (car c)))))
	112 (else (loop))))))))
	113
	114 (define (clear-line)
	115 (printf "\r~a" (string #\escape #\[ #\K)))
	116
	117 (define (ask-yes-or-no msg)
	118 (eqv? #\y (ask-for-choice msg "y" "n")))
	119
	120 (define (random-username)
	121 (let* ((first-random (random-bytes 2))
	122 (last-random (random-bytes 2))
	123 (->number (lambda (u8v)
	124 (bitwise-ior (u8vector-ref u8v 1)
	125 (arithmetic-shift (u8vector-ref u8v 1)…
	126 (first-index (->number first-random))
	127 (last-index (->number last-random))
	128 (number-first-names (car (alist-ref 'sizes names)))
	129 (number-last-names (cadr (alist-ref 'sizes names)))
	130 (first-name (list-ref (alist-ref 'first names)
	131 (modulo first-index number-first-names)))
	132 (last-name (list-ref (alist-ref 'last names)
	133 (modulo last-index number-last-names)))
	134 (number (->string (u8vector-ref (random-bytes 1) 0))))
	135 (string-titlecase (string-append first-name "_" last-name number))))
	136
	137 (define (new-password)
	138 (define (ask-for-manual-password)
	139 (with-stty
	140 '(not echo)
	141 (lambda ()
	142 (printf "Enter new password: ")
	143 (let ((l (read-line)))
	144 (print "\r")
	145 l))))
	146 (let manual-loop ()
	147 (if (ask-yes-or-no "Invent your own password?")
	148 (let ((p1 (ask-for-manual-password))
	149 (p2 (ask-for-manual-password)))
	150 (unless (equal? p1 p2) (print "Passwords do not match.") (manu…
	151 p1)
	152 (let password-loop ((e wanted-entropy)
	153 (modes password-modes))
	154 (let* ((m (car modes))
	155 (p (generate-new-password e (cdr m)))
	156 (entropy-delta (cond ((< e 64) 8)
	157 ((< e 128) 16)
	158 (else 32))))
	159 (printf "Mode ~a, Length ~a chars, entropy ~a bits~%"
	160 (car m)
	161 (string-length p)
	162 (quotient (* (string-length p) (entropy-per-char (ch…
	163 (print p)
	164 (let dialog-loop ()
	165 (let ((choice (ask-for-choice "Use this password?" "y" "n"…
	166 (case choice
	167 ((#\space #\n) (password-loop e modes))
	168 ((#\+) (password-loop (+ e entropy-delta) modes))
	169 ((#\-) (password-loop (max 32 (- e entropy-delta)) mod…
	170 ((#\m) (password-loop e (append (cdr modes) (list m))))
	171 ((#\?)
	172 (printf "y - accept password~%+ - increase password l…
	173 (dialog-loop))
	174 (else p)))))))))
	175
	176 (define (get-hashed-passphrase)
	177 (with-stty
	178 '(not echo)
	179 (lambda ()
	180 (display "Enter passphrase: " (current-error-port))
	181 (let ((l (read-line)))
	182 (newline (current-error-port))
	183 (hash-passphrase l)))))
	184
	185 (define (enc/dec-file content passphrase op)
	186 (let ((sbox (op passphrase))
	187 (nonce (make-u8vector symmetric-box-noncebytes 0)))
	188 (sbox content nonce)))
	189
	190 (define (decrypt-file file passphrase)
	191 (let ((content (with-input-from-file file (lambda () (read-string #f))…
	192 (enc/dec-file content passphrase symmetric-unbox)))
	193
	194 (define (check-content content)
	195 (condition-case
	196 (with-input-from-string
	197 (with-output-to-string
	198 (lambda () (pp content)))
	199 read)
	200 (e () (error "Internal error: Writing of unserialisable object detect…
	201
	202 (define (encrypt-file file content passphrase)
	203 (check-content content)
	204 (let ((cyphertext (enc/dec-file
	205 (with-output-to-string (lambda () (pp content)))
	206 passphrase
	207 symmetric-box)))
	208 (unless cyphertext
	209 (print "Error: cannot encrypt password store.")
	210 (exit 1))
	211 (with-output-to-file file
	212 (lambda () (display cyphertext)))))
	213
	214 (define (db-keys alist) (map car alist))
	215
	216 (define (update-db db key #!key user password comment)
	217 (let ((entry (or (alist-ref key db equal?) (make-list 3 ""))))
	218 (alist-update key
	219 (match-let (((u p c) entry))
	220 (list
	221 (or user u)
	222 (or password p)
	223 (or comment c)))
	224 db
	225 equal?)))
	226
	227 (define (print-entries entries #!key show-password (show-headers #t) (pr…
	228 (let ((users (map first entries))
	229 (passwords (if show-password
	230 (map second entries)
	231 (make-list (length entries) "***")))
	232 (comments (map third entries))
	233 (dates (map (lambda (e)
	234 (time->string (seconds->local-time (inexact->exact…
	235 entries)))
	236 (fmt #t
	237 (tabular
	238 (cat (if show-headers (cat "Label" nl) "") (fmt-join dsp prefi…
	239 (cat (if show-headers (cat "Username" nl) "") (fmt-join dsp us…
	240 (cat (if show-headers (cat "Passwords" nl) "") (fmt-join dsp p…
	241 (cat (if show-headers (cat "Comments" nl) "") (fmt-join dsp co…
	242 (cat (if show-headers (cat "Last modified" nl) "") (fmt-join d…
	243
	244
	245 (define (check-access f)
	246 (and (file-exists? f)
	247 (file-readable? f)
	248 (file-writable? f)))
	249
	250 (define options
	251 `((init
	252 "Initialise password store"
	253 (required #f)
	254 (value #f)
	255 (single-char #\i))
	256 (add
	257 "Add a new entry to the password store"
	258 (required #f)
	259 (value (required ACCOUNT)
	260 (predicate ,string?))
	261 (single-char #\a))
	262 (password
	263 "Get the password for a given entry"
	264 (required #f)
	265 (value (required ACCOUNT)
	266 (predicate ,string?))
	267 (single-char #\p))
	268 (update
	269 "Change an existing entry in the database"
	270 (required #f)
	271 (value (required ACCOUNT)
	272 (predicate ,string?))
	273 (single-char #\u))
	274 (delete
	275 "Drop an entry from the database"
	276 (required #f)
	277 (value (required ACCOUNT)
	278 (predicate ,string?))
	279 (single-char #\d))
	280 (list
	281 "Shows all info for an entry. Does not show the password."
	282 (required #f)
	283 (value (optional ACCOUNT)
	284 (predicate ,string?))
	285 (single-char #\l))
	286 (change-passphrase
	287 "Reencrypts the store with a new passphrase. Use it regularily."
	288 (required #f)
	289 (value #f)
	290 (single-char #\c))
	291 (database-file
	292 "Use FILE as the database"
	293 (required #f)
	294 (single-char #\f)
	295 (value (required FILE)))
	296 (merge
	297 "Merge their DB file into our DB file"
	298 (required #f)
	299 (single-char #\m)
	300 (value (required THEIRS)
	301 (predicate ,check-access)))
	302 (export
	303 "Prints the database as an association list (s-expression) on stdou…
	304 (required #f)
	305 (value #f))
	306 (import
	307 "Reads an association list from FILE, the inverse of export."
	308 (required #f)
	309 (value (required FILE)
	310 (predicate ,check-access)))
	311 (check-age
	312 "Checks the age of the passwords to remind you of changing it"
	313 (required #f)
	314 (value (required DAYS)
	315 (predicate ,(lambda (o) (number? (string->number o))))))
	316 (version
	317 "Print program version"
	318 (required #f)
	319 (single-char #\v)
	320 (value #f))
	321 (help
	322 "Prints this help"
	323 (required #f)
	324 (single-char #\h)
	325 (value #f))))
	326
	327 (define (banner)
	328 (printf "~a Version ~a (~a) -- ~a~%" program-name-string program-versi…
	329
	330 (define (do-add db-name db p e)
	331 (when (alist-ref e db equal?)
	332 (print "Error: An entry for '" e "' already exists.")
	333 (exit 1))
	334 (let ((user (prompt-for "Username" (random-username)))
	335 (password (new-password))
	336 (comment (prompt-for "Comment")))
	337 (encrypt-file db-name
	338 (cons (list e user password comment (current-seconds))…
	339 p)
	340 (print "Entry for " e " added.")))
	341
	342 (define (do-update db-name db p account)
	343 (cond ((alist-ref account db equal?) =>
	344 (lambda (e)
	345 (let ((user (prompt-for "User" (first e)))
	346 (comment (prompt-for "Comment" (third e)))
	347 (password (if (ask-yes-or-no "Change password?")
	348 (new-password)
	349 (second e))))
	350 (encrypt-file db-name
	351 (alist-update account (list user password com…
	352 p)
	353 (print "Entry '" account "' has been updated."))))
	354 (else (fprintf (current-error-port) "Error: Entry for '~a' not f…
	355 (exit 1))))
	356
	357 (define (do-delete db-name db p account)
	358 (cond ((alist-ref account db equal?) =>
	359 (lambda (e)
	360 (print-entries (list e) prefixes: (list account) show-header:…
	361 (cond ((ask-yes-or-no "Really delete account?")
	362 (encrypt-file db-name (alist-delete account db equal?…
	363 (print "Entry '" account "' deleted."))
	364 (else (print "Nothing done.")))))
	365 (else (fprintf (current-error-port) "Error: Entry for '~a' not f…
	366 (exit 1))))
	367
	368 (define (do-list db account)
	369 (let* ((regex (string->irregex (if (string? account)
	370 (string-append "." account ".")
	371 ".*")
	372 'i 'utf8))
	373 (accounts
	374 (sort (filter (lambda (k)
	375 (irregex-match regex k))
	376 (db-keys db))
	377 string<=)))
	378 (cond ((null? (db-keys db))
	379 (print "Error: No keys in password store")
	380 (exit 1))
	381 ((null? accounts)
	382 (print "Error: No entry for " account " found.")
	383 (exit 1))
	384 (else
	385 (print-entries (map
	386 (lambda (account-name)
	387 (alist-ref account-name db equal?))
	388 accounts)
	389 prefixes: accounts)))))
	390
	391 (define (do-password db e)
	392 (cond ((alist-ref e db equal?) =>
	393 (lambda (e)
	394 (display (second e))
	395 (when (terminal-port? (current-output-port))
	396 (newline))))
	397 (else
	398 (fprintf (current-error-port) "Error: password for '~a' not fou…
	399 (exit 1))))
	400
	401 (define (do-init db-name content)
	402 (define (really-init)
	403 (print "I will ask you twice for the passphrase to encrypt the passw…
	404 (let ((passphrase1 (get-hashed-passphrase))
	405 (passphrase2 (get-hashed-passphrase)))
	406 (unless (equal? passphrase1 passphrase2)
	407 (print "Error: Passphrases do not match.")
	408 (exit 1))
	409 (encrypt-file db-name content passphrase1)
	410 (print "Password store " db-name " initialised.")))
	411 (cond ((and (check-access db-name)
	412 (ask-yes-or-no (sprintf "~a does exist, do you want to OVE…
	413 (really-init))
	414 ((not (check-access db-name))
	415 (really-init))
	416 (else
	417 (print "Nothing done."))))
	418
	419 (define (do-change-passphrase db-name db old-passphrase)
	420 (print "I will ask you twice for the new passphrase.")
	421 (let ((passphrase1 (get-hashed-passphrase))
	422 (passphrase2 (get-hashed-passphrase)))
	423 (cond ((not (equal? passphrase1 passphrase2))
	424 (print "Error: Passphrases do not match.")
	425 (exit 1))
	426 ((equal? passphrase1 old-passphrase)
	427 (print "Error: Passphrase is the same as old passphrase")
	428 (exit 1))
	429 (else (encrypt-file db-name db passphrase1)
	430 (print "Password store " db-name " reencrypted.")))))
	431
	432 (define (do-merge db-name db passphrase theirs)
	433 (define (merge-entries account mine theirs)
	434 (let ((show-password? (ask-yes-or-no "Show passwords?")))
	435 (print "Account " account)
	436 (let dialog-loop ()
	437 (print-entries (list mine theirs) prefixes: '("MINE" "THEIRS") s…
	438 (unless (or (equal? (second mine) (second theirs)) show-password…
	439 (print "Password MISMATCH"))
	440 (let ((choice (ask-for-choice "Use which version?" "m" "t" "s" "…
	441 (case choice
	442 ((#\m) (print "Taking my version") mine)
	443 ((#\t) (print "Taking their version") theirs)
	444 ((#\s) (print "Skipping " account " keeping ours.") mine)
	445 ((#\?) (printf "m\ttake my version.~%t\ttake their version~%…
	446 (dialog-loop))
	447 (else (dialog-loop)))))))
	448 (print "Enter passphrase for db file " theirs)
	449 (let* ((passphrase-theirs (get-hashed-passphrase))
	450 (db-theirs (or (with-input-from-string
	451 (or (decrypt-file theirs passphrase-theirs) "#f…
	452 (begin (fprintf (current-error-port) "Error whil…
	453 (cond ((equal? db db-theirs)
	454 (print "Databases are the same."))
	455 (else
	456 (encrypt-file
	457 db-name
	458 (fold
	459 (lambda (entry db)
	460 (let ((account (car entry))
	461 (theirs (cdr entry)))
	462 (cond ((equal? theirs (alist-ref account db equal?)) db)
	463 ((alist-ref account db equal?) =>
	464 (lambda (ours)
	465 (let ((new (merge-entries account ours theirs)…
	466 (alist-update account new db equal?))))
	467 (else
	468 (print-entries (list theirs) prefixes: (list (sp…
	469 (alist-cons account theirs db)))))
	470 db
	471 db-theirs)
	472 passphrase)))))
	473
	474 (define (do-age-check db days)
	475 (define (expires-in-seconds entry)
	476 (+ (fifth entry)
	477 (* 60 60 24 days)))
	478 (let* ((now (current-seconds))
	479 (old-passwords
	480 (filter
	481 (lambda (p)
	482 (< (expires-in-seconds p) now))
	483 db)))
	484 (if (pair? old-passwords)
	485 (begin
	486 (print "These passwords are older than " days " days.")
	487 (do-list old-passwords 'all))
	488 (print "Your passwords are younger than " days " days."))))
	489
	490 (define (main args)
	491 (set-buffering-mode! (current-output-port) #:none)
	492 (when (null? args)
	493 (banner) (print (usage options)) (exit 1))
	494 (let* ((opts
	495 (condition-case
	496 (getopt-long args options)
	497 (e (exn)
	498 (print "Error: "
	499 ((condition-property-accessor 'exn 'arguments) e) " "
	500 ((condition-property-accessor 'exn 'message) e))
	501 (banner)
	502 (print (usage options))
	503 (exit 1))))
	504 (db-name (or (alist-ref 'database-file opts)
	505 (make-pathname (get-environment-variable "HOME") "…
	506 (init (alist-ref 'init opts)))
	507
	508 (unless (null? (alist-ref '@ opts equal?))
	509 (fprintf (current-error-port) "Warning: superfluous option g…
	510 (fprintf (current-error-port) "Using database file ~a~%" db-name)
	511 (unless (or init (check-access db-name))
	512 (print "Error database " db-name " does not exist or has wro…
	513 (cond
	514 ((alist-ref 'help opts) (banner) (print (usage options)))
	515 ((alist-ref 'version opts) (banner))
	516 ((alist-ref 'import opts) => (lambda (f)
	517 (do-init db-name (with-input-from-fi…
	518
	519 (init (do-init db-name '()))
	520 (else
	521 (let* ((passphrase (get-hashed-passphrase))
	522 (db (or (with-input-from-string
	523 (or (decrypt-file db-name passphrase) "#f") rea…
	524 (begin (fprintf (current-error-port) "Error while d…
	525 (cond
	526 ((alist-ref 'change-passphrase opts)
	527 (do-change-passphrase db-name db passphrase))
	528 ((alist-ref 'add opts) => (lambda (e) (do-add db-name db passph…
	529 ((alist-ref 'list opts) => (lambda (e) (do-list db e)))
	530 ((alist-ref 'export opts) (pp db))
	531 ((alist-ref 'delete opts) => (lambda (e) (do-delete db-name db …
	532 ((alist-ref 'update opts) => (lambda (e) (do-update db-name db …
	533 ((alist-ref 'password opts) => (lambda (e) (do-password db e)))
	534 ((alist-ref 'merge opts) => (lambda (theirs) (do-merge db-name …
	535 ((alist-ref 'check-age opts) => (lambda (days) (do-age-check db…
	536 (else (banner) (print "Error: Don't know what to do") (print (u…
	537 (exit 0)))
	538 )
	539
	540 (import pee (chicken process-context))
	541 (main (cdr (argv)))