summaryrefslogtreecommitdiff
path: root/shroud
diff options
context:
space:
mode:
authorDavid Thompson <davet@gnu.org>2015-05-25 21:12:15 -0400
committerDavid Thompson <davet@gnu.org>2015-05-25 21:12:15 -0400
commit333a5fd740c02d3bfa962fb8d5141788b93a4946 (patch)
tree74fd0f114aebb0b509fed27c2531a056d326c07f /shroud
parent101a426a269c2f038068514f67cd0605f3f54698 (diff)
Add show, hide, and remove subcommands.
Diffstat (limited to 'shroud')
-rw-r--r--shroud/config.scm9
-rw-r--r--shroud/secret.scm44
-rw-r--r--shroud/ui.scm47
-rw-r--r--shroud/ui/hide.scm90
-rw-r--r--shroud/ui/remove.scm63
-rw-r--r--shroud/ui/show.scm79
-rw-r--r--shroud/utils.scm73
7 files changed, 371 insertions, 34 deletions
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)))))