secrets/secrets

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

#|
    Copyright 2020-2024 Martin Puppe

    This file is part of Secrets.

    Secrets 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.

    Secrets 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 Secrets.  If not, see <https://www.gnu.org/licenses/>.
|#

(require typed/json)

(struct secret-file ([source-path : Path]
                     [name : String]
                     [size : Nonnegative-Integer]
                     [owner : String]
                     [group : String]
                     [mode : String])
  #:transparent)

(define-type Config
  (HashTable Symbol (U Config-Target Config-Basedir Config-FileList)))

(define-type Config-Target String)
(define-type Config-Basedir String)
(define-type Config-FileList (Listof Config-File))
(define-type Config-File (U String (HashTable Symbol String)))

(: make-file (-> Config-File Path secret-file))
(define (make-file file-hash-or-string source-basedir)
  (let* ([file-hash : (HashTable Symbol String) (if(string?
                                                     file-hash-or-string)
                                                      (hash 'source
                                                            file-hash-or-string)
                                                      file-hash-or-string)]
         [source-path (simplify-path
                       (path->complete-path (hash-ref file-hash 'source)
                                            source-basedir))]
         [fs (file-size source-path)]
         [name (or (hash-ref file-hash 'name #f)
                   (path->string
                    (assert (file-name-from-path source-path))))]
         [owner (or (hash-ref file-hash 'owner #f) "root")]
         [group (or (hash-ref file-hash 'group #f) "root")]
         [mode (or (hash-ref file-hash 'mode #f) "400")])
    (secret-file source-path name fs owner group mode)))

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

read basedir

# exit if $basedir is an empty string
test -z "$basedir" && exit 1

# create $basedif if it does not exist
if test ! -d "$basedir"; then
    install -o root -g root -m 755 -d "$basedir"
fi
rm -rf "$basedir"/*

while read name; do
    fullpath="$basedir/$name"
    install -o root -g root -m 600 /dev/null "$fullpath"
    read size
    head --bytes="$size" - > "$fullpath"
    read owner
    read group
    read mode
    chown "$owner":"$group" "$fullpath"
    chmod "$mode" "$fullpath"
done
EOF
  )

(: string->base64 (-> String String))
(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)))

(: deploy-secrets (-> Config Path Void))
(define (deploy-secrets config
                        [source-basedir (current-directory)])

  (: handle-stderr (-> Input-Port (Channelof Symbol) Void))
  (define (handle-stderr stderr phase-channel)
    (define p (current-error-port))
    
    (let loop ([displayed ""]
               [last-char : (U Char False) #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 _) (assert char char?)
                       (loop "" char (read-char stderr))]

        [(list _ #\newline _) (display last-char p)
                              (assert char char?)
                              (loop "" char (read-char stderr))]
        
        [(list _ _ _) (display last-char p)
                      (assert last-char char?)
                      (assert char char?)
                      (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))

  (: handle-stdin (-> Output-Port
                      (Channelof Symbol)
                      Path-String
                      (Listof secret-file)
                      Void))
  (define (handle-stdin stdin phase-channel basedir files)

    (: send-data (-> Void))
    (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)
             (lambda ([file-port : Input-Port])
               (copy-port file-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 (assert (or
                           (hash-ref config 'basedir #f) "/var/lib/secrets")
                          string?)]
         [files (map
                 (lambda
                     ([f : Config-File])
                   (make-file f source-basedir))
                 (cast (hash-ref config 'files)
                       (Listof Config-File)))]
         [target (assert (hash-ref config 'target) string?)])
    (let-values ([(sp _ stdin stderr) (subprocess
                                       (current-output-port) #f #f
                                       (assert
                                        (find-executable-path "ssh") path?)
                                       target
                                       (format
                                        "bash -c '~a'"
                                        (string-replace bootstrap-script
                                                        "'" "\'")))])
      (let* ([phase-channel : (Channelof Symbol) (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))
      (subprocess-wait sp)
      (let ([status (subprocess-status sp)])
        (unless (equal? status 0)
          (exit 1)))))
  
  (void))

(: cfg-file (Parameterof String))
(define cfg-file (make-parameter ""))
(command-line 
 #:args ([config-file "secrets.json"])
 (cfg-file (assert config-file string?)))

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