blob: 3f28840ba2c68a06e5b5e14bef09438f2b3cf8b0 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
|
;;; 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)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 vlist)
#:use-module (srfi srfi-1)
#:export (vhash-ref
vhash-replace
vhash-values
alist-compact
alist-pick
gpg-binary
call-with-encrypted-output-file
call-with-decrypted-input-file
mkdir-p))
(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 (alist-compact alist)
"Remove all duplicate keys from ALIST."
(let loop ((alist alist)
(keys '())
(result '()))
(match alist
(() (reverse result))
(((key . value) . tail)
(if (member key keys)
(loop tail keys result)
(loop tail (cons key keys)
(alist-cons key value result)))))))
(define (alist-pick alist key)
"Return a list of the values in ALIST that are associated with KEY."
(fold-right (lambda (key+value result)
(match key+value
((k . value)
(if (equal? key k)
(cons value result)
result))))
'() alist))
(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)))))
;; Written by Ludovic Courtès for GNU Guix.
(define (mkdir-p dir)
"Create directory DIR and all its ancestors."
(define absolute?
(string-prefix? "/" dir))
(define not-slash
(char-set-complement (char-set #\/)))
(let loop ((components (string-tokenize dir not-slash))
(root (if absolute?
""
".")))
(match components
((head tail ...)
(let ((path (string-append root "/" head)))
(catch 'system-error
(lambda ()
(mkdir path)
(loop tail path))
(lambda args
(if (= EEXIST (system-error-errno args))
(loop tail path)
(apply throw args))))))
(() #t))))
|
