secrets/secrets

#! /usr/bin/env racket
#lang racket

(require json)

(struct secret-file (source-path
                     name
                     size
                     owner
                     group
                     mode)
  #:transparent)

(define 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 file-config source-basedir)
  (-> (or/c string? file-contract) path-string? secret-file?)
  (let* ([file-config (if (string? file-config)
                          (hash 'source file-config)
                          file-config)]
         [source-path (simplify-path
                       (path->complete-path (dict-ref file-config 'source)
                                            source-basedir))]
         [fs (file-size source-path)]
         [name (dict-ref file-config 'name (file-name-from-path source-path))]
         [owner (dict-ref file-config 'owner "root")]
         [group (dict-ref file-config 'group "root")]
         [mode (dict-ref file-config 'mode "400")])
    (secret-file source-path name fs owner group mode)))

(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 file-list-contract
  (listof
   (or/c
    path-string?
    file-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) file-list-contract])])))

(define receive-script #<<EOF
#!/usr/bin/env bash
set -euo pipefail
rm "$0"
echo "!*data" >&2

read basedir
if test -d "$basedir"; then
    rm -rf "$basedir"
fi
mkdir -p "$basedir"
chown root:root "$basedir"
chmod 755 "$basedir"

while read name; do
    fullpath="$basedir/$name"
    read size
    head --bytes="$size" - > "$fullpath"
    read owner
    read group
    read mode
    chown "$owner":"$group" "$fullpath"
    chmod "$mode" "$fullpath"
done
EOF
  )

(define (string->base64 str)
  (with-input-from-string str
    (lambda ()
      (with-output-to-string
        (lambda ()
          (system "base64 -w 0"))))))

(define bootstrap-script
  (format #<<EOF
set -euo pipefail
script=~s
scriptfile=$(mktemp)
echo $script | base64 --decode > "$scriptfile"
exec env LC_ALL=C \
sudo -S bash "$scriptfile"
EOF
          (string->base64 receive-script)))

(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
                                 [source-basedir (current-directory)])
  (->* (config-contract) (path-string?) void?)

  (define (handle-stderr stderr phase-channel)
    (define p (current-error-port))
    
    (let loop ([displayed ""]
               [last-char #f]
               [char (read-char stderr)])
      (match (list displayed last-char char)
        [(list _ (? char? _) (? eof-object? _))
         (display last-char p)
         (close-input-port stderr)]

        [(list _ _ (? eof-object? _)) (close-input-port stderr)]

        [(list "" #\! #\*)
         (match (read-line stderr)
           ["data" (channel-put phase-channel 'data)
                   (copy-port stderr (current-error-port))
                   (close-input-port stderr)]
           [(? eof-object? _) (display last-char p)
                              (display char p)
                              (close-input-port stderr)]

           [line (display last-char p)
                 (display char p)
                 (displayln line p)
                 (loop "" #f (read-char stderr))])]
        
        [(list (pregexp #px"^\\[sudo\\] password for \\S*") #\: #\space)
         (display last-char p)
         (display char p)
         (channel-put phase-channel 'password)
         (loop "" #f (read-char stderr))]

        [(list _ #f _) (loop "" char (read-char stderr))]

        [(list _ #\newline _) (display last-char p)
                              (loop "" char (read-char stderr))]
        
        [(list _ _ _) (display last-char p)
                      (loop (string-append displayed (string last-char))
                            char (read-char stderr))])))

    (define (read-password)
      (system "stty -echo")
      (let ([line (read-line)])
        (system "stty echo")
        line))
     
  (define (handle-stdin stdin phase-channel basedir files)

    (define (send-data)
      (displayln basedir stdin)
      (let send-files ([files files])
        (match files
          [(list-rest (and (struct secret-file _) f) rest)
           (printf "Transfer ~a …\n" (secret-file-name f))
           (displayln (secret-file-name f) stdin)
           (displayln (secret-file-size f) stdin)
           (call-with-input-file (secret-file-source-path f)
             (curryr copy-port stdin))
           (displayln (secret-file-owner f) stdin)
           (displayln (secret-file-group f) stdin)
           (displayln (secret-file-mode f) stdin)
           (send-files rest)]
          [(list) (void)])))

    (let loop ()
      (match (channel-get phase-channel)
        ['password (displayln (read-password) stdin)
                   (displayln "" (current-error-port))
                   (flush-output stdin)
                   (loop)]
        ['data (begin
                 (send-data)
                 (close-output-port stdin))])))
  
  (let* ([basedir (dict-ref config 'basedir "/var/lib/secrets")]
         [files (map
                 (curryr make-file source-basedir)
                 (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 bootstrap-script
                                                        "'" "\'")))])
      (let* ([phase-channel (make-channel)]
             [stderr-thread (thread
                             (lambda ()
                               (handle-stderr stderr phase-channel)))]
             [stdin-thread (thread
                            (lambda ()
                              (handle-stdin stdin phase-channel basedir files)))])
        
        (thread-wait stderr-thread)
        (thread-wait stdin-thread))))
  
  (void))

(define cfg-file (make-parameter #f))
(command-line 
 #:args ([config-file "secrets.json"])
 (cfg-file config-file))

(let* ([config (call-with-input-file (cfg-file) read-json)])
  (deploy-secrets config (path->complete-path (path-only (cfg-file))))
  (displayln "Done."))