diff options
| -rw-r--r-- | .dir-locals.el | 8 | ||||
| -rw-r--r-- | Makefile.am | 5 | ||||
| -rw-r--r-- | README | 15 | ||||
| -rw-r--r-- | shroud/config.scm | 9 | ||||
| -rw-r--r-- | shroud/secret.scm | 44 | ||||
| -rw-r--r-- | shroud/ui.scm | 47 | ||||
| -rw-r--r-- | shroud/ui/hide.scm | 90 | ||||
| -rw-r--r-- | shroud/ui/remove.scm | 63 | ||||
| -rw-r--r-- | shroud/ui/show.scm | 79 | ||||
| -rw-r--r-- | shroud/utils.scm | 73 |
10 files changed, 389 insertions, 44 deletions
diff --git a/.dir-locals.el b/.dir-locals.el new file mode 100644 index 0000000..e2cc424 --- /dev/null +++ b/.dir-locals.el @@ -0,0 +1,8 @@ +((scheme-mode + . + ((indent-tabs-mode . nil) + (eval . (put 'call-with-pipe* 'scheme-indent-function 2)) + (eval . (put 'call-with-output-pipe* 'scheme-indent-function 1)) + (eval . (put 'call-with-input-pipe* 'scheme-indent-function 1)) + (eval . (put 'call-with-encrypted-output-file 'scheme-indent-function 2)) + (eval . (put 'call-with-decrypted-input-file 'scheme-indent-function 1))))) diff --git a/Makefile.am b/Makefile.am index 655a5ab..557b91c 100644 --- a/Makefile.am +++ b/Makefile.am @@ -41,4 +41,7 @@ SOURCES = \ shroud/config.scm \ shroud/utils.scm \ shroud/secret.scm \ - shroud/ui.scm + shroud/ui.scm \ + shroud/ui/hide.scm \ + shroud/ui/remove.scm \ + shroud/ui/show.scm @@ -7,20 +7,17 @@ with a [[gnupg.org][GnuPG]] key. * Usage #+BEGIN_SRC sh - # Add a new password - shroud add "bank account" hackme + # Add a new secret + shroud hide --id=bank-account --username=foobar --password=hackme - # Show a saved password - shroud show "bank account" + # Replace an existing secret + shroud hide --replace --id=bank-account --username=foobar --password=hackmepls - # Show all passwords - shroud list-all + # Show a saved password + shroud show bank-account # Delete a password shroud remove "personal email" - - # Delete all passwords - shroud clear #+END_SRC * Dependencies diff --git a/shroud/config.scm b/shroud/config.scm index c83bdfe..803a3ac 100644 --- a/shroud/config.scm +++ b/shroud/config.scm @@ -15,13 +15,6 @@ ;;; along with Shroud. If not, see <http://www.gnu.org/licenses/>. (define-module (shroud config) - #:export (%shroud-version - %shroud-gpg-binary - %shroud-database-file - %shroud-user-id)) + #:export (%shroud-version)) (define %shroud-version "0.1") -(define %shroud-gpg-binary "gpg") -(define %shroud-database-file - (string-append (getenv "HOME") "/.shroud-db")) -(define %shroud-user-id #f) diff --git a/shroud/secret.scm b/shroud/secret.scm index f9f499a..22d2961 100644 --- a/shroud/secret.scm +++ b/shroud/secret.scm @@ -16,41 +16,61 @@ (define-module (shroud secret) #:use-module (ice-9 match) + #:use-module (ice-9 vlist) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) + #:use-module (shroud utils) #:export (make-secret secret? secret-id - secret-content + secret-username + secret-password alist->secret secret->alist load-secrets - save-secrets)) + save-secrets + secrets-by-id)) (define-record-type <secret> - (make-secret id content) + (make-secret id username password) secret? - (id secret-id) - (content secret-content)) + (id secret-id) + (username secret-username) + (password secret-password)) (define (alist->secret alist) "Convert ALIST into a <secret> record." - (make-secret (assq-ref alist 'id) (assq-ref alist 'content))) + (make-secret (assq-ref alist 'id) + (assq-ref alist 'username) + (assq-ref alist 'password))) (define (secret->alist secret) "Convert SECRET into an alist." (match secret - (($ <secret> id content) + (($ <secret> id username password) `((id . ,id) - (content . ,content))))) + (username . ,username) + (password . ,password))))) (define (load-secrets file) "Load secrets from FILE, or return '() if FILE does not exist." (if (file-exists? file) - (map alist->secret (call-with-input-file file read)) + (map alist->secret + ;; Handle existing file that isn't PGP encrypted. + (let ((stored (call-with-decrypted-input-file file read))) + (if (eof-object? stored) + (throw 'decrypt-fail file) + stored))) '())) -(define (save-secrets secrets file) - "Write SECRETS to FILE." - (call-with-output-file file +(define (save-secrets secrets file user-id) + "Write SECRETS to FILE, encrypted for USER-ID." + (call-with-encrypted-output-file file user-id (lambda (port) (write (map secret->alist secrets) port)))) + +(define (secrets-by-id secrets) + "Convert the list SECRETS into a vhash keyed off of the secret id." + (fold (lambda (secret result) + (vhash-cons (secret-id secret) secret result)) + vlist-null secrets)) diff --git a/shroud/ui.scm b/shroud/ui.scm index cbc0683..1656f08 100644 --- a/shroud/ui.scm +++ b/shroud/ui.scm @@ -19,18 +19,28 @@ #:use-module (ice-9 match) #:use-module (srfi srfi-37) #:use-module (shroud config) + #:use-module (shroud utils) #:use-module (shroud secret) - #:export (program-name + #:export (simple-args-fold + program-name show-version-and-exit leave make-user-module load* shroud-main)) +(define (simple-args-fold args options default-options) + (args-fold args options + (lambda (opt name arg result) + (leave "~A: unrecognized option" name)) + (lambda (arg result) + (leave "~A: extraneuous argument" arg)) + default-options)) + (define program-name (make-parameter "shroud")) (define %commands - '("add" "show" "list-all" "remove" "clear")) + '("hide" "show" "remove")) (define (show-help) (format #t "Usage: shroud COMMAND ARGS... @@ -104,9 +114,14 @@ ARGS is the list of arguments received by the 'throw' handler." (define (load-config) "Load and evaluate user configuration file." - (append (load* (string-append (getenv "HOME") "/.shroud") - (make-user-module '((shroud config)))) - %default-config)) + (let ((config (append (load* (string-append (getenv "HOME") "/.shroud") + (make-user-module '((shroud config)))) + %default-config))) + + (unless (assq-ref config 'user-id) + (leave "user-id must be specified in configuration")) + + config)) (define (command-proc command) "Return the procedure for COMMAND." @@ -139,9 +154,19 @@ ARGS is the list of arguments received by the 'throw' handler." (((= string->symbol command) . args) (let* ((config (load-config)) (db-file (assq-ref config 'database-file)) - (db (load-secrets db-file)) - (proc (command-proc command)) - (result (parameterize ((program-name (make-program-name command))) - (apply proc config db args)))) - (unless (eq? db result) - (save-secrets result db-file)))))) + (user-id (assq-ref config 'user-id)) + (gpg (assq-ref config 'gpg-binary))) + (parameterize ((gpg-binary gpg)) + ;; Don't load database until needed to avoid pinentry prompt + ;; when running commands like 'shroud show --help'. + (let* ((db (delay + (catch 'decrypt-fail + (lambda () (load-secrets db-file)) + (lambda (key file) + (leave "~a: could not decrypt database" file))))) + (proc (command-proc command)) + (result (parameterize ((program-name (make-program-name + command))) + (apply proc config db args)))) + (unless (eq? db result) + (save-secrets result db-file user-id)))))))) diff --git a/shroud/ui/hide.scm b/shroud/ui/hide.scm new file mode 100644 index 0000000..934abf8 --- /dev/null +++ b/shroud/ui/hide.scm @@ -0,0 +1,90 @@ +;;; Shroud +;;; Copyright © 2015 David Thompson <davet@gnu.org> +;;; +;;; Shroud is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; Shroud is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Shroud. If not, see <http://www.gnu.org/licenses/>. + +(define-module (shroud ui hide) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (ice-9 vlist) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-37) + #:use-module (shroud utils) + #:use-module (shroud secret) + #:use-module (shroud ui) + #:export (shroud-hide)) + +(define (show-help) + (format #t "Usage: shroud hide [OPTION] --id=ID --username=USERNAME --password=PASSWORD +Add a new secret to the database.~%") + (display " + -i, --id unique ID for secret") + (display " + -u, --username username") + (display " + -p, --password password") + (display " + -r, --replace replace existing username/password if it exists") + (display " + -h, --help display this help and exit") + (display " + --version display version information and exit") + (newline)) + +(define %options + (list (option '(#\i "id") #t #f + (lambda (opt name arg result) + (alist-cons 'id arg result))) + (option '(#\u "username") #t #f + (lambda (opt name arg result) + (alist-cons 'username arg result))) + (option '(#\p "password") #t #f + (lambda (opt name arg result) + (alist-cons 'password arg result))) + (option '(#\r "replace") #f #f + (lambda (opt name arg result) + (alist-cons 'replace? #t result))) + (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '("--version") #f #f + (lambda args + (show-version-and-exit))))) + +(define %default-options '()) + +(define (shroud-hide config db . args) + (let* ((opts (simple-args-fold args %options %default-options)) + (id (assq-ref opts 'id)) + (username (assq-ref opts 'username)) + (password (assq-ref opts 'password)) + (replace? (assq-ref opts 'replace?))) + + (unless id + (leave "no secret id specified")) + (unless username + (leave "no username specified")) + (unless password + (leave "no password specified")) + + (let* ((db (secrets-by-id (force db))) + (existing (vhash-ref db id)) + (vcons (if existing vhash-replace vhash-cons)) + (secret (make-secret id username password))) + + (when (and (not replace?) existing) + (leave "~a: secret already defined" id)) + + (vhash-values (vcons id secret db))))) diff --git a/shroud/ui/remove.scm b/shroud/ui/remove.scm new file mode 100644 index 0000000..239618f --- /dev/null +++ b/shroud/ui/remove.scm @@ -0,0 +1,63 @@ +;;; Shroud +;;; Copyright © 2015 David Thompson <davet@gnu.org> +;;; +;;; Shroud is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; Shroud is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Shroud. If not, see <http://www.gnu.org/licenses/>. + +(define-module (shroud ui remove) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (ice-9 vlist) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-37) + #:use-module (shroud utils) + #:use-module (shroud secret) + #:use-module (shroud ui) + #:export (shroud-remove)) + +(define (show-help) + (format #t "Usage: shroud remove [OPTION] id +Remove a secret from the database.~%") + (display " + -h, --help display this help and exit") + (display " + --version display version information and exit") + (newline)) + +(define %options + (list (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '("--version") #f #f + (lambda args + (show-version-and-exit))))) + +(define %default-options '()) + +(define (shroud-remove config db . args) + (let* ((opts (args-fold args %options + (lambda (opt name arg result) + (leave "~A: unrecognized option" name)) + (lambda (arg result) + (if (assq-ref result 'id) + (leave "~A: extraneuous argument" arg) + (alist-cons 'id arg result))) + %default-options)) + (id (assq-ref opts 'id)) + (db (secrets-by-id (force db)))) + + (unless (vhash-ref db id) + (leave "secret '~a' is undefined" id)) + + (vhash-values (vhash-delete id db)))) diff --git a/shroud/ui/show.scm b/shroud/ui/show.scm new file mode 100644 index 0000000..e56d8dd --- /dev/null +++ b/shroud/ui/show.scm @@ -0,0 +1,79 @@ +;;; Shroud +;;; Copyright © 2015 David Thompson <davet@gnu.org> +;;; +;;; Shroud is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; Shroud is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Shroud. If not, see <http://www.gnu.org/licenses/>. + +(define-module (shroud ui show) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-37) + #:use-module (shroud utils) + #:use-module (shroud secret) + #:use-module (shroud ui) + #:export (shroud-show)) + +(define (show-help) + (format #t "Usage: shroud show [OPTION] id +Show secret named ID.~%") + (display " + -p, --password show only the password") + (display " + -h, --help display this help and exit") + (display " + --version display version information and exit") + (newline)) + +(define %options + (list (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '("--version") #f #f + (lambda args + (show-version-and-exit))) + (option '(#\p "password") #f #f + (lambda (opt name arg result) + (alist-cons 'password #t result))))) + +(define %default-options '()) + +(define (shroud-show config db . args) + (let* ((opts (args-fold args %options + (lambda (opt name arg result) + (leave "~A: unrecognized option" name)) + (lambda (arg result) + (if (assq-ref result 'id) + (leave "~A: extraneuous argument" arg) + (alist-cons 'id arg result))) + %default-options)) + (id (assq-ref opts 'id)) + (password? (assq-ref opts 'password))) + + (unless id + (leave "no secret id specified")) + + (let* ((db (secrets-by-id (force db))) + (secret (vhash-ref db id))) + (unless secret + (leave "~a: secret undefined" id)) + + (if password? + (display (secret-password secret)) + (format #t "username: ~a~%password: ~a~%" + (secret-username secret) + (secret-password secret))))) + + ;; We don't alter the database. + db) diff --git a/shroud/utils.scm b/shroud/utils.scm index a0714af..e3b317d 100644 --- a/shroud/utils.scm +++ b/shroud/utils.scm @@ -17,7 +17,74 @@ (define-module (shroud utils) #:use-module (ice-9 match) #:use-module (ice-9 popen) - #:export ()) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 vlist) + #:use-module (srfi srfi-1) + #:export (vhash-ref + vhash-replace + vhash-values + gpg-binary + call-with-encrypted-output-file + call-with-decrypted-input-file)) -;; TODO: Add call-with-encrypted-output-file and -;; call-with-decrypted-input-file. +(define (vhash-ref vhash key) + "Return the value associated with KEY in VHASH or #f if there is no +such key." + (match (vhash-assoc key vhash) + ((_ . value) value) + (_ #f))) + +(define (vhash-replace key value vhash) + "Replace the association of KEY with VALUE in VHASH." + (vhash-cons key value (vhash-delete key vhash))) + +(define (vhash-values vhash) + "Return a list of the values within VHASH." + (vhash-fold-right (lambda (key value result) + (cons value result)) + '() vhash)) + +(define gpg-binary (make-parameter "gpg")) + +(define (call-with-pipe* program+args mode proc) + "Apply PROC with an open pipe in the given MODE for the subprocess +COMMAND+ARGS." + (let ((pipe (apply open-pipe* mode program+args))) + (dynamic-wind + (const #t) + (lambda () + (proc pipe)) + (lambda () + (close-pipe pipe))))) + +(define (call-with-output-pipe* program+args proc) + "Apply PROC with an open output pipe for the subprocess +PROGRAM+ARGS." + (call-with-pipe* program+args OPEN_WRITE proc)) + +(define (call-with-input-pipe* program+args proc) + "Apply PROC with an open input pipe for the subprocess +PROGRAM+ARGS." + (call-with-pipe* program+args OPEN_READ proc)) + +(define (call-with-encrypted-output-file file user-id proc) + "Apply PROC with an output port that writes encrypted data to FILE +for the recipient USER-ID." + (call-with-output-pipe* `(,(gpg-binary) + "--no-tty" "--batch" "--yes" + "--encrypt" "--armor" + "--recipient" ,user-id + "--output" ,file) + proc)) + +(define (call-with-decrypted-input-file file proc) + "Apply PROC with an input port containing the decrypted contents of +FILE." + ;; Suppress info/debug/error messages. + (call-with-output-file "/dev/null" + (lambda (port) + (parameterize ((current-error-port port)) + (call-with-input-pipe* `(,(gpg-binary) + "--no-tty" "--batch" "--yes" + "--decrypt" ,file) + proc))))) |