Add X clipboard support.

* configure.ac (XCLIP): New variable.
* package.scm: Add xclip dependency.
* shroud/config.scm: Untrack.  Now automatically generated.
* shroud/config.scm.in: New file.
* shroud/utils.scm (call-with-clipboard): New procedure.
* shroud/ui/show.scm (%options): Add --clipboard option.
  (show-help): Add help text for --clipboard.
  (display-secret): New procedure.
  (shroud-show): Handle --clipboard option.

6 files changed, 53 insertions, 21 deletions

diff --git a/.gitignore b/.gitignore
index 1e88dcf..3a3acc7 100644
--- a/.gitignore
+++ b/.gitignore
@@ -9,3 +9,4 @@
 /scripts/shroud
 /Makefile
 *.go
+/shroud/config.scm
diff --git a/configure.ac b/configure.ac
index 4b6de58..3ddbac9 100644
--- a/configure.ac
+++ b/configure.ac
@@ -9,7 +9,10 @@ AM_SILENT_RULES([yes])
 AC_CONFIG_FILES([Makefile])
 AC_CONFIG_FILES([pre-inst-env], [chmod +x pre-inst-env])
 AC_CONFIG_FILES([scripts/shroud], [chmod +x scripts/shroud])
+AC_CONFIG_FILES([shroud/config.scm])
 
 GUILE_PROGS([2.0.11])
 
+AC_PATH_PROG([XCLIP], [xclip])
+
 AC_OUTPUT
diff --git a/package.scm b/package.scm
index 8bda732..2cb202f 100644
--- a/package.scm
+++ b/package.scm
@@ -24,7 +24,8 @@
              (guix licenses)
              (guix build-system gnu)
              (gnu))
-(use-package-modules autotools pkg-config guile gnupg)
+
+(use-package-modules autotools pkg-config guile gnupg xdisorg)
 
 (package
   (name "shroud")
@@ -37,7 +38,8 @@
      ("automake" ,automake)))
   (inputs
    `(("guile" ,guile-2.0)
-     ("gnupg" ,gnupg)))
+     ("gnupg" ,gnupg)
+     ("xclip" ,xclip)))
   (synopsis "Simple password manager")
   (description "Shroud is a simple password manager with a
 command-line interface.  The password database is stored as a Scheme
diff --git a/shroud/config.scm b/shroud/config.scm.in
index 803a3ac..00d6f39 100644
--- a/shroud/config.scm
+++ b/shroud/config.scm.in
@@ -1,3 +1,5 @@
+;;; -*- scheme -*-
+;;;
 ;;; Shroud
 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
 ;;;
@@ -15,6 +17,9 @@
 ;;; along with Shroud.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (shroud config)
-  #:export (%shroud-version))
+  #:export (%shroud-version
+            %xclip))
 
 (define %shroud-version "0.1")
+
+(define %xclip "@XCLIP@")
diff --git a/shroud/ui/show.scm b/shroud/ui/show.scm
index fd076eb..21a35e2 100644
--- a/shroud/ui/show.scm
+++ b/shroud/ui/show.scm
@@ -28,6 +28,8 @@
   (format #t "Usage: shroud show [OPTION] ID [KEY ...]
 Show secret named ID.~%")
   (display "
+  -c, --clipboard        copy output to the X clipboard")
+  (display "
   -h, --help             display this help and exit")
   (display "
   --version              display version information and exit")
@@ -40,7 +42,10 @@ Show secret named ID.~%")
                   (exit 0)))
         (option '("version") #f #f
                 (lambda args
-                  (show-version-and-exit)))))
+                  (show-version-and-exit)))
+        (option '("clipboard" #\c) #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'clipboard? #t result)))))
 
 (define %default-options '())
 
@@ -54,28 +59,38 @@ Show secret named ID.~%")
                    (alist-cons 'id arg result)))
              %default-options))
 
+(define* (display-secret secret keys #:optional (port (current-output-port)))
+  (match keys
+    (()
+     (for-each (match-lambda
+                ((key . value)
+                 (format port "~a\t~a~%" key value)))
+               (secret-contents secret)))
+    ((keys ...)
+     (for-each (match-lambda
+                ((key . value)
+                 (when (member key keys)
+                   (format port "~a~%" value))))
+               (secret-contents secret)))))
+
 (define (shroud-show config db . args)
-  (let* ((opts   (process-args args))
-         (id     (leave-if-false (assq-ref opts 'id)
-                                 "no secret ID given"))
-         (keys   (alist-pick opts 'key))
-         (secret (vhash-ref (secrets-by-id (force db)) id)))
+  (let* ((opts       (process-args args))
+         (id         (leave-if-false (assq-ref opts 'id)
+                                     "no secret ID given"))
+         (keys       (alist-pick opts 'key))
+         (clipboard? (assq-ref opts 'clipboard?))
+         (secret     (vhash-ref (secrets-by-id (force db)) id)))
 
     (unless secret
       (leave "secret '~a' does not exist" id))
 
-    (match keys
-      (()
-       (for-each (match-lambda
-                  ((key . value)
-                   (format #t "~a\t~a~%" key value)))
-                 (secret-contents secret)))
-      ((keys ...)
-       (for-each (match-lambda
-                  ((key . value)
-                   (when (member key keys)
-                     (format #t "~a~%" value))))
-                 (secret-contents secret))))
+    (if clipboard?
+        (call-with-clipboard
+         (lambda (port)
+           (display-secret secret keys port)
+           (display "copied secret to clipboard\n"
+                    (current-error-port))))
+        (display-secret secret keys))
 
     ;; Database remains unaltered.
     db))
diff --git a/shroud/utils.scm b/shroud/utils.scm
index 3f28840..58695e4 100644
--- a/shroud/utils.scm
+++ b/shroud/utils.scm
@@ -20,6 +20,7 @@
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 vlist)
   #:use-module (srfi srfi-1)
+  #:use-module (shroud config)
   #:export (vhash-ref
             vhash-replace
             vhash-values
@@ -28,6 +29,7 @@
             gpg-binary
             call-with-encrypted-output-file
             call-with-decrypted-input-file
+            call-with-clipboard
             mkdir-p))
 
 (define (vhash-ref vhash key)
@@ -115,6 +117,10 @@ FILE."
                                  "--decrypt" ,file)
           proc)))))
 
+(define (call-with-clipboard proc)
+  "Call PROC with an open output port to the X clipboard."
+  (call-with-output-pipe* (list %xclip "-selection" "clipboard") proc))
+
 ;; Written by Ludovic Courtès for GNU Guix.
 (define (mkdir-p dir)
   "Create directory DIR and all its ancestors."