Initial commit

secrets

@@ -0,0 +1,288 @@
+#! /usr/bin/env racket
+#lang racket
+
+(require json)
+
+(struct file (source-path
+              destination-path
+              owner
+              group
+              mode)
+  #:transparent)
+
+(define raw-file-contract
+  (and/c
+     (curryr dict-has-key? 'source)
+     (hash/dc
+      [k1 (or/c 'source
+                'name
+                'owner
+                'group
+                'mode)]
+      [v1 (k1)
+          (case k1
+            [(source) path-string?]
+            [(name) path-string?]
+            [(owner) string?]
+            [(group) string?]
+            [(mode) string?])])))
+
+(define/contract (make-file basedir file-config)
+  (-> path-string? (or/c string? raw-file-contract) file?)
+  (let* ([file-config (if (string? file-config) (hash 'source file-config) file-config)]
+         [source-path (string->path (dict-ref file-config 'source))]
+         [name (dict-ref file-config 'name (file-name-from-path source-path))]
+         [destination-path (build-path basedir name)]
+         [owner (dict-ref file-config 'owner "root")]
+         [group (dict-ref file-config 'owner "root")]
+         [mode (dict-ref file-config 'mode "600")])
+    (file source-path destination-path owner group mode)))
+
+(struct config (host basedir files) #:transparent)
+
+(define (make-config attrs)
+  (config (dict-ref attrs '#:host)
+          (dict-ref attrs '#:basedir "/var/lib/secrets")
+          (dict-ref attrs '#:files '())))
+
+(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?)
+
+  (stream-empty? (stream-filter
+                  (negate (curry dict-has-key? d))
+                  (set->stream keys))))
+
+(define raw-file-list-contract
+  (listof
+   (or/c
+    path-string?
+    raw-file-contract)))
+
+(define raw-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/contract (process-config raw-config)
+  (-> raw-config-contract config?)
+  
+  (define (file-entry-to-file entry)
+    (if (string? entry)
+        (make-file entry)
+        (begin
+          (let* ([source (dict-ref entry 'source)]
+                 [entry (if (dict-mutable? entry) (dict-copy entry) entry)]
+                 [entry (dict-remove entry 'source)])
+          (simple-keyword-apply make-file entry (list source))))))
+
+  (define (process-file-entries entries)
+    (map file-entry-to-file entries))
+
+  (let* ([host (dict-ref raw-config 'host)]
+         [files (dict-ref raw-config 'files)])
+  (make-config #:host (dict-ref raw-config 'host)
+               #:files (process-file-entries (dict-ref raw-config 'files)))))
+
+(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 receive-script #<<EOF
+#!/usr/bin/env bash
+set -euxo pipefail
+rm $0
+echo "!*data" >&2
+read foo
+echo $foo
+exit
+
+echo "Hello, this is the receiving script"
+read foo
+echo $foo
+exit 1
+read basedir
+echo rm -r "$basedir"
+echo mkdir "$basedir"
+chown root:root "$basedir"
+chmod 755 "$basedir"
+
+while read path; do
+    fullpath="$basedir/$path"
+    echo "\$fullpath: $fullpath"
+    read filesize
+    echo "head --bytes=$size - > $fullpath"
+    read owner
+    read group
+    read mode
+    echo "chown $owner:$group $fullpath"
+    echo "chmod $mode $fullpath"
+done
+EOF
+  )
+
+(define (script-as-base64)
+  (with-input-from-string receive-script
+    (lambda ()
+      (with-output-to-string
+        (lambda ()
+          (system "base64 -w 0"))))))
+
+(define transfer-script
+  (format #<<EOF
+set -euxo pipefail
+uname -a
+script=~s
+scriptfile=$(mktemp)
+echo $script | base64 --decode > "$scriptfile"
+exec env LC_ALL=C \
+sudo -S bash "$scriptfile"
+EOF
+          (script-as-base64)))
+
+(define/contract (deploy-secrets config)
+  (-> raw-config-contract void?)
+
+  (define (read-err err phase-channel)
+    (define p (current-error-port))
+    
+    (let loop ([displayed ""]
+               [last-char #f]
+               [char (read-char err)])
+      (match (list displayed last-char char)
+        [(list _ (? char? _) (? eof-object? _))
+         (display last-char p)
+         (close-input-port err)]
+
+        [(list _ _ (? eof-object? _)) (close-input-port err)]
+
+        [(list "" #\! #\*)
+         (match (read-line err)
+           ["data" (channel-put phase-channel 'data)
+                   (copy-port err (current-error-port))
+                   (close-input-port err)]
+           [(? eof-object? _) (display last-char p)
+                              (display char p)
+                              (close-input-port err)]
+
+           [line (display last-char p)
+                 (display char p)
+                 (displayln line p)
+                 (loop "" #f (read-char err))])]
+        
+        [(list (pregexp #px"^\\[sudo\\] password for \\S*") #\: #\space)
+         (display last-char p)
+         (display char p)
+         (channel-put phase-channel 'password)
+         (loop "" #f (read-char err))]
+
+        [(list _ #f _) (loop "" char (read-char err))]
+
+        [(list _ #\newline _) (display last-char p)
+                              (loop "" char (read-char err))]
+        
+        [(list _ _ _) (display last-char p)
+                      (loop (string-append displayed (string last-char))
+                            char (read-char err))])))
+
+  (define (read-password)
+    (define script #<<EOF
+read -s password
+echo "$password"
+EOF
+      )
+
+    (define password-with-newline
+      (with-output-to-string
+        (lambda ()
+          (system (format "bash -c '~a'" script)))))
+
+    ;; clean trailing newline
+    (string-replace password-with-newline #rx"\n$" ""))
+     
+  (define (foo in phase-channel)
+    (match (channel-get phase-channel)
+      ['password (displayln (read-password) in)
+                 (displayln "" (current-error-port))
+                 (flush-output in)
+                 (foo in phase-channel)]
+      ['data (begin
+               (displayln "PAYLOAD" in)
+               (close-output-port in))]))
+  
+  (let* ([basedir (dict-ref config 'basedir "/var/lib/secrets")]
+         [files (map (curry make-file basedir) (dict-ref config 'files))]
+         [host (dict-ref config 'host)])
+    (printf "basedir: ~s\n" basedir)
+    (printf "files: ~s\n" files)
+    (let-values ([(sp _ in err) (subprocess
+                                  (current-output-port) #f #f 
+                                  (find-executable-path "ssh")
+                                  "giles.mpuppe.de"
+                                  (format
+                                   "bash -c '~a'"
+                                   (string-replace transfer-script "'" "\'")))])
+      (let* ([phase-channel (make-channel)]
+             [err-thread (thread (lambda () (read-err err phase-channel)))]
+             [foo-thread (thread (lambda () (foo in phase-channel)))])
+        
+        (thread-wait err-thread)
+        (thread-wait foo-thread))))
+  
+  (void))
+
+(let* ([config (call-with-input-file "config.json" read-json)])
+  (printf "config: ~s\n" config)
+  (deploy-secrets config))

shell.nix

@@ -0,0 +1,7 @@
+{ pkgs ? import <nixpkgs> {} }:
+pkgs.mkShell {
+  buildInputs = with pkgs; [
+    openssh
+    racket-minimal
+  ];
+}