summaryrefslogtreecommitdiff
path: root/shroud
diff options
context:
space:
mode:
authorDavid Thompson <davet@gnu.org>2015-05-25 00:28:03 -0400
committerDavid Thompson <davet@gnu.org>2015-05-25 00:28:03 -0400
commit101a426a269c2f038068514f67cd0605f3f54698 (patch)
treecf6f532d9c0ecc9a9131392dda674dc244db9e34 /shroud
First commit.
Diffstat (limited to 'shroud')
-rw-r--r--shroud/config.scm27
-rw-r--r--shroud/secret.scm56
-rw-r--r--shroud/ui.scm147
-rw-r--r--shroud/utils.scm23
4 files changed, 253 insertions, 0 deletions
diff --git a/shroud/config.scm b/shroud/config.scm
new file mode 100644
index 0000000..c83bdfe
--- /dev/null
+++ b/shroud/config.scm
@@ -0,0 +1,27 @@
+;;; 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 config)
+ #:export (%shroud-version
+ %shroud-gpg-binary
+ %shroud-database-file
+ %shroud-user-id))
+
+(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
new file mode 100644
index 0000000..f9f499a
--- /dev/null
+++ b/shroud/secret.scm
@@ -0,0 +1,56 @@
+;;; 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 secret)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-9)
+ #:export (make-secret
+ secret?
+ secret-id
+ secret-content
+ alist->secret
+ secret->alist
+ load-secrets
+ save-secrets))
+
+(define-record-type <secret>
+ (make-secret id content)
+ secret?
+ (id secret-id)
+ (content secret-content))
+
+(define (alist->secret alist)
+ "Convert ALIST into a <secret> record."
+ (make-secret (assq-ref alist 'id) (assq-ref alist 'content)))
+
+(define (secret->alist secret)
+ "Convert SECRET into an alist."
+ (match secret
+ (($ <secret> id content)
+ `((id . ,id)
+ (content . ,content)))))
+
+(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))
+ '()))
+
+(define (save-secrets secrets file)
+ "Write SECRETS to FILE."
+ (call-with-output-file file
+ (lambda (port)
+ (write (map secret->alist secrets) port))))
diff --git a/shroud/ui.scm b/shroud/ui.scm
new file mode 100644
index 0000000..cbc0683
--- /dev/null
+++ b/shroud/ui.scm
@@ -0,0 +1,147 @@
+;;; 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)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-37)
+ #:use-module (shroud config)
+ #:use-module (shroud secret)
+ #:export (program-name
+ show-version-and-exit
+ leave
+ make-user-module
+ load*
+ shroud-main))
+
+(define program-name (make-parameter "shroud"))
+
+(define %commands
+ '("add" "show" "list-all" "remove" "clear"))
+
+(define (show-help)
+ (format #t "Usage: shroud COMMAND ARGS...
+Run COMMAND with ARGS.~%~%")
+ (format #t "COMMAND may be one of the sub-commands listed below:~%~%")
+ (format #t "~{ ~a~%~}" %commands))
+
+(define (show-usage)
+ (format #t "Try `shroud --help' for more information.~%")
+ (exit 1))
+
+(define (show-version-and-exit)
+ (format #t "~a ~a
+Copyright (C) 2015 David Thompson <davet@gnu.org>
+License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>
+This is free software: you are free to change and redistribute it.
+There is NO WARRANTY, to the extent permitted by law.~%"
+ (program-name) %shroud-version)
+ (exit 0))
+
+(define (leave format-string . args)
+ "Display error message and exist."
+ (apply format (current-error-port) format-string args)
+ (newline)
+ (exit 1))
+
+(define (make-user-module modules)
+ "Return a new user module with the additional MODULES loaded."
+ ;; Module in which the machine description file is loaded.
+ (let ((module (make-fresh-user-module)))
+ (for-each (lambda (iface)
+ (module-use! module (resolve-interface iface)))
+ modules)
+ module))
+
+(define (report-load-error file args)
+ "Report the failure to load FILE, a user-provided Scheme file, and exit.
+ARGS is the list of arguments received by the 'throw' handler."
+ (match args
+ (('system-error . _)
+ (let ((err (system-error-errno args)))
+ (leave "failed to load '~a': ~a~%" file (strerror err))))
+ (('syntax-error proc message properties form . rest)
+ (let ((file (assq-ref properties 'filename))
+ (line (assq-ref properties 'line))
+ (col (assq-ref properties 'column)))
+ (format (current-error-port) "~a:~a:~a: error: ~a~%"
+ file (and line (1+ line)) col message))
+ (exit 1))
+ ((error args ...)
+ (format (current-error-port) "failed to load '~a':~%" file)
+ (apply display-error #f (current-error-port) args)
+ (exit 1))))
+
+(define (load* file user-module)
+ "Load the user provided Scheme source code FILE."
+ (catch #t
+ (lambda ()
+ (set! %fresh-auto-compile #t)
+
+ (save-module-excursion
+ (lambda ()
+ (set-current-module user-module)
+ (primitive-load file))))
+ (lambda args
+ (report-load-error file args))))
+
+(define %default-config
+ `((database-file . ,(string-append (getenv "HOME") "/.shroud-db"))
+ (gpg-binary . "gpg")))
+
+(define (load-config)
+ "Load and evaluate user configuration file."
+ (append (load* (string-append (getenv "HOME") "/.shroud")
+ (make-user-module '((shroud config))))
+ %default-config))
+
+(define (command-proc command)
+ "Return the procedure for COMMAND."
+ (let* ((module
+ (catch 'misc-error
+ (lambda ()
+ (resolve-interface `(shroud ui ,command)))
+ (lambda -
+ (format (current-error-port) "~a: invalid subcommand~%" command)
+ (show-usage)))))
+ (module-ref module (symbol-append 'shroud- command))))
+
+(define (option? str)
+ "Return #t if STR is an option string."
+ (string-prefix? "-" str))
+
+(define (make-program-name command)
+ "Return a program name string for COMMAND."
+ (string-append "shroud " (symbol->string command)))
+
+(define (shroud-main . args)
+ (match args
+ (() (show-usage))
+ ((or ("-h") ("--help"))
+ (show-help))
+ (("--version")
+ (show-version-and-exit))
+ (((? option? opt) _ ...)
+ (format (current-error-port) "shroud: unrecognized option '~a'~%" opt))
+ (((= 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))))))
diff --git a/shroud/utils.scm b/shroud/utils.scm
new file mode 100644
index 0000000..a0714af
--- /dev/null
+++ b/shroud/utils.scm
@@ -0,0 +1,23 @@
+;;; 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 utils)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 popen)
+ #:export ())
+
+;; TODO: Add call-with-encrypted-output-file and
+;; call-with-decrypted-input-file.