Reorganize and clean up

This commit is contained in:
Martin Puppe 2020-11-24 20:38:09 +01:00
parent d3e45ee306
commit fad70955eb

94
secrets
View file

@ -11,7 +11,7 @@
mode)
#:transparent)
(define raw-file-contract
(define file-contract
(and/c
(curryr dict-has-key? 'source)
(hash/dc
@ -29,7 +29,7 @@
[(mode) string?])])))
(define/contract (make-file file-config)
(-> (or/c string? raw-file-contract) secret-file?)
(-> (or/c string? file-contract) secret-file?)
(let* ([file-config (if (string? file-config) (hash 'source file-config) file-config)]
[source-path (string->path (dict-ref file-config 'source))]
[fs (file-size source-path)]
@ -39,18 +39,6 @@
[mode (dict-ref file-config 'mode "400")])
(secret-file source-path name fs owner group mode)))
(define (raw-config? obj)
(define required-keys (seteq 'host 'files))
(define optional-keys (seteq 'basedir))
(define permitted-keys
(set-union required-keys optional-keys))
(and (hash? obj)
(hash-has-key? obj 'host)
(hash-has-key? obj 'files)
(empty? (filter (lambda (k) (not (set-member? permitted-keys k))) (hash-keys obj)))))
(define/contract (dict-has-keys? d keys)
(-> dict? (or/c generic-set?) boolean?)
@ -58,61 +46,19 @@
(negate (curry dict-has-key? d))
(set->stream keys))))
(define raw-file-list-contract
(define file-list-contract
(listof
(or/c
path-string?
raw-file-contract)))
file-contract)))
(define raw-config-contract
(define config-contract
(and/c (curryr dict-has-keys? '(host files))
(hash/dc [k (or/c 'host 'files 'basedir)]
[v (k) (case k
[(host) string?]
[(basedir) string?]
[(files) raw-file-list-contract])])))
(define/contract (simple-keyword-apply proc kwargs args)
(-> procedure? (hash/c (or/c symbol? string? keyword?) any/c) (listof any/c) any/c)
(define (ensure-keyword x)
(if (keyword? x)
x
(if (symbol? x)
(string->keyword (symbol->string x))
(string->keyword x))))
(define (convert-key-to-keyword pair)
(let ((key (ensure-keyword (car pair)))
(value (cdr pair)))
(cons key value)))
(define (split-pair pair lists)
""
(let* ([keys (car lists)]
[values (cdr lists)]
(new-keys (cons (car pair) keys))
(new-values (cons (cdr pair) values)))
(cons new-keys new-values)))
(let* ((sorted-list (sort
(sequence->list
(sequence-map convert-key-to-keyword
(in-dict-pairs kwargs)))
keyword<?
#:key car))
(seperate-lists (foldr split-pair '(() . ()) sorted-list))
(keywords (car seperate-lists))
(values (cdr seperate-lists)))
(keyword-apply proc keywords values args)))
(define (read-loop input-port)
(let ([line (read-line input-port)])
(if (eof-object? line)
(close-input-port input-port)
(begin
(printf "~a\n" line)
(read-loop input-port)))))
[(files) file-list-contract])])))
(define receive-script #<<EOF
#!/usr/bin/env bash
@ -141,14 +87,14 @@ done
EOF
)
(define (script-as-base64)
(with-input-from-string receive-script
(define (string->base64 str)
(with-input-from-string str
(lambda ()
(with-output-to-string
(lambda ()
(system "base64 -w 0"))))))
(define transfer-script
(define bootstrap-script
(format #<<EOF
set -euo pipefail
script=~s
@ -157,10 +103,18 @@ echo $script | base64 --decode > "$scriptfile"
exec env LC_ALL=C \
sudo -S bash "$scriptfile"
EOF
(script-as-base64)))
(string->base64 receive-script)))
(define/contract (deploy-secrets raw-config)
(-> raw-config-contract void?)
(define (read-loop input-port)
(let ([line (read-line input-port)])
(if (eof-object? line)
(close-input-port input-port)
(begin
(printf "~a\n" line)
(read-loop input-port)))))
(define/contract (deploy-secrets config)
(-> config-contract void?)
(define (handle-stderr stderr phase-channel)
(define p (current-error-port))
@ -238,16 +192,16 @@ EOF
(send-data)
(close-output-port stdin))])))
(let* ([basedir (dict-ref raw-config 'basedir "/var/lib/secrets")]
[files (map make-file (dict-ref raw-config 'files))]
[host (dict-ref raw-config 'host)])
(let* ([basedir (dict-ref config 'basedir "/var/lib/secrets")]
[files (map make-file (dict-ref config 'files))]
[host (dict-ref config 'host)])
(let-values ([(sp _ stdin stderr) (subprocess
(current-output-port) #f #f
(find-executable-path "ssh")
host
(format
"bash -c '~a'"
(string-replace transfer-script
(string-replace bootstrap-script
"'" "\'")))])
(let* ([phase-channel (make-channel)]
[stderr-thread (thread