pee.scm - pee - Pee a password manager;Pee - because you have to...
(HTM) git clone git://vernunftzentrum.de/pee.git
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) LICENSE
---
pee.scm (20918B)
---
1 ;; Pee - A password manager for the command line
2 ;;
3 ;; Copyright (c) 2016 Christian Kellermann <ckeen@pestilenz.org>
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 WARRANTIES
10 ;; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
11 ;; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
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 OF
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 "abcdefhijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890!@#$%^&*()-=~?/\|+,:.<>{}[]")
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 2)) 100))))
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) (entropy-per-char (chars-for-mode password-chars mode)))))))))
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) 8))))
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.") (manual-loop))
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 (chars-for-mode password-chars (cdr m)))) 100))
163 (print p)
164 (let dialog-loop ()
165 (let ((choice (ask-for-choice "Use this password?" "y" "n" "+" "-" " " "m" "?")))
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)) modes))
170 ((#\m) (password-loop e (append (cdr modes) (list m))))
171 ((#\?)
172 (printf "y - accept password~%+ - increase password length~%- - decrease password length~%n/space - new password~%m\t - next password mode~%")
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 detected."))))
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) (prefixes '()))
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 (fourth e))) "%Y-%m-%d %H:%M:%S"))
235 entries)))
236 (fmt #t
237 (tabular
238 (cat (if show-headers (cat "Label" nl) "") (fmt-join dsp prefixes nl)) " "
239 (cat (if show-headers (cat "Username" nl) "") (fmt-join dsp users nl)) " "
240 (cat (if show-headers (cat "Passwords" nl) "") (fmt-join dsp passwords nl)) " "
241 (cat (if show-headers (cat "Comments" nl) "") (fmt-join dsp comments nl)) " "
242 (cat (if show-headers (cat "Last modified" nl) "") (fmt-join dsp dates nl))))))
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 stdout"
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-version commit-id program-description))
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)) db)
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 comment (current-seconds)) db equal?)
352 p)
353 (print "Entry '" account "' has been updated."))))
354 (else (fprintf (current-error-port) "Error: Entry for '~a' not found.~%" account)
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: #f)
361 (cond ((ask-yes-or-no "Really delete account?")
362 (encrypt-file db-name (alist-delete account db equal?) p)
363 (print "Entry '" account "' deleted."))
364 (else (print "Nothing done.")))))
365 (else (fprintf (current-error-port) "Error: Entry for '~a' not found.~%" account)
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 found.~%" e)
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 password store with.")
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 OVERWRITE ALL THE CONTENTS?" db-name)))
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") show-password: show-password? show-headers: #f)
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~%s\tskip the decision, same as \"m\"~%?\tthis help~%")
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") read)
452 (begin (fprintf (current-error-port) "Error while decrypting ~a, wrong key?~%" theirs) (exit 1)))))
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 (sprintf "NEW ~a" account)) show-headers: #f)
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") ".passdb")))
506 (init (alist-ref 'init opts)))
507
508 (unless (null? (alist-ref '@ opts equal?))
509 (fprintf (current-error-port) "Warning: superfluous option given: ~a~%" (alist-ref '@ opts equal?)))
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 wrong permissions.") (exit 1))
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-file f read))))
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") read)
524 (begin (fprintf (current-error-port) "Error while decrypting ~a, wrong key?~%" db-name) (exit 1)))))
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 passphrase e)))
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 passphrase e)))
532 ((alist-ref 'update opts) => (lambda (e) (do-update db-name db passphrase e)))
533 ((alist-ref 'password opts) => (lambda (e) (do-password db e)))
534 ((alist-ref 'merge opts) => (lambda (theirs) (do-merge db-name db passphrase theirs)))
535 ((alist-ref 'check-age opts) => (lambda (days) (do-age-check db (string->number days))))
536 (else (banner) (print "Error: Don't know what to do") (print (usage options)) (exit 1))))))
537 (exit 0)))
538 )
539
540 (import pee (chicken process-context))
541 (main (cdr (argv)))