Add show, hide, and remove subcommands.

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
diff --git a/README b/README
index ba3f1a9..c5d9376 100644
--- a/README
+++ b/README
@@ -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)))))