Add encrypted S3 drive backend
ober
43e3832ff63feafe9e3db5248e72a5fc2ef8dfa4
--- a/README.md +++ b/README.md @@ -31,6 +31,46 @@ After `jdrive creds store`, commands such as `jdrive ls`, `jdrive volumes`, and `jdrive mount` use the selected profile's encrypted credentials automatically when you do not pass `--username` or token options. +## Encrypted S3 Backend + +The S3 backend stores local profile state under `~/.jdrive`, not XDG. It uses +AWS-compatible credentials from the normal AWS environment/profile files, wraps +a random drive key in a local `scrypt` + `chacha20-poly1305` vault, encrypts +the remote manifest, and stores file contents under opaque S3 object keys. + +Bootstrap a profile: + +```sh +jdrive s3 init --bucket BUCKET --prefix jdrive --region us-east-1 +jdrive s3 profile-status +jdrive s3 unlock-test +``` + +For S3-compatible providers, add `--endpoint URL --path-style` when needed. +Use `--aws-profile NAME` to select an AWS profile. + +Add optional built-in YubiKey PIV unlock material: + +```sh +jdrive s3 init --bucket BUCKET --yubikey-mode piv +``` + +Daily operations: + +```sh +jdrive s3 mkdir /backups +jdrive s3 cp ./notes.txt /backups/notes.txt +jdrive s3 cp -r ./backup-dir /backups +jdrive s3 ls /backups +jdrive s3 cat /backups/notes.txt +jdrive s3 get /backups/notes.txt ./notes-restored.txt +jdrive s3 rm -r /backups/backup-dir +``` + +Set `JDRIVE_VAULT_PASSWORD` or pass `--vault-password-env ENV_NAME` for +automation. Set `JDRIVE_PIV_PIN` or pass `--piv-pin-env ENV_NAME` when the +profile was initialized with `--yubikey-mode piv`. + ## Runtime Status Current runtime code is Scheme/Jerboa only: @@ -63,6 +103,12 @@ Current runtime code is Scheme/Jerboa only: and create-file request payload assembly from unlocked keys and generated Drive crypto, encrypted block upload plans, encrypted xattrs, manifest signatures, and revision commit payloads. +- [protonstorage/s3/config.ss](protonstorage/s3/config.ss) - S3-compatible + endpoint, credential, region, path-style, and object-key helpers. +- [protonstorage/s3/drive.ss](protonstorage/s3/drive.ss) - encrypted S3 drive + profile/vault, encrypted manifest, encrypted object upload/download/list, + checksum verification, retry wrappers, and optional YubiKey PIV unlock + material through `jerboa-yubikey`. The cloned Go/rclone/Proton client projects under `~/mine` are references only. They are used to map endpoint shapes and crypto behavior while porting. @@ -255,6 +301,10 @@ libraries, and a wrapper that sets the runtime library search path. ## Remaining Work +- Add live S3 integration tests gated by bucket/provider env vars. +- Add chunked streaming reads/writes and multipart encrypted uploads for very + large objects. +- Add full sync/check semantics, include/exclude filters, and conflict policy. - Finish daemon control socket/background lifecycle and durable operation queue. - Add richer metadata update operations beyond size-changing writes and rename/move. --- a/docs/jerboa-drive-plan.md +++ b/docs/jerboa-drive-plan.md @@ -91,10 +91,29 @@ Completed so far: - `jerboa-drive` now resolves `~/mine/jerboa-aws` and exposes: - `jdrive s3 status` - `jdrive s3 target` + - `jdrive s3 init` + - `jdrive s3 profile-status` + - `jdrive s3 unlock-test` + - `jdrive s3 mkdir` + - `jdrive s3 cp [-r]` + - `jdrive s3 ls` + - `jdrive s3 cat` + - `jdrive s3 get` + - `jdrive s3 rm [-r]` +- `jerboa-drive` has a first encrypted S3 drive profile implementation: + - local state under `~/.jdrive` + - local drive-key vault with `scrypt` and `chacha20-poly1305` + - optional built-in `jerboa-yubikey` PIV unlock material + - encrypted remote manifest + - opaque encrypted file object keys + - recursive upload + - plaintext SHA-256 verification after decrypt + - retry wrappers around current S3 object operations Remaining: -- Add transient retry/backoff wrappers and apply them to idempotent S3 calls. - Add optional live S3 integration tests gated by env vars. +- Add chunked streaming reads/writes and use S3 multipart for large encrypted + files. - Prove multipart round-trip against a real S3-compatible bucket. Add or verify these `jerboa-aws` capabilities before building the drive layer: @@ -141,6 +160,21 @@ Acceptance gate: ## Phase 3: Encrypted Drive Data Model +Status: first milestone implemented with a simpler single-manifest, +single-writer layout. The current implementation stores: + +```text +~/.jdrive/profiles/<profile>/s3.config.json +~/.jdrive/profiles/<profile>/s3.key.vault.json +<prefix>/v1/manifest.bin +<prefix>/v1/objects/<hmac-path-id>.bin +``` + +The manifest and file objects are encrypted with authenticated +ChaCha20-Poly1305. The bucket sees opaque object names and encrypted bytes. +The next model should evolve this toward generationed manifests, conditional +writes, and chunk objects. + Object namespace inside bucket: ```text @@ -203,6 +237,12 @@ Acceptance gate: ## Phase 4: Unlock and YubiKey Integration +Status: passphrase-only and passphrase + built-in `jerboa-yubikey` PIV unlock +material are implemented for S3 profiles. This does not shell out to `ykman`. +OATH/TOTP remains useful as an interactive second factor, but because TOTP is +time-varying it is not used as persistent vault key material in the current +format. + Local state directory: ```text --- a/docs/user-guide.md +++ b/docs/user-guide.md @@ -7,6 +7,9 @@ Drive data, and how to mount the Drive tree through FUSE. The project is a Jerboa-native Proton Drive client. It does not use rclone or a Go helper at runtime. +It also includes an S3-compatible encrypted drive backend. S3 profile state +lives under `~/.jdrive`; Proton profile state remains under `~/.jproton`. + ## Short CLI Use the installed binary directly: @@ -57,6 +60,10 @@ Implemented today: - Local profile directories under `~/.jproton`. - Optional encrypted Proton username/password vault protected by a separate password you provide. +- S3-compatible encrypted drive profile under `~/.jdrive` with encrypted + manifest, encrypted file objects, recursive upload, list, cat, get, rm, + checksum verification, retry wrappers, and optional built-in YubiKey PIV + unlock material. - Host binary build, host bundle build, and Linux/FreeBSD cross-build targets. Important current limitations: @@ -69,6 +76,66 @@ Important current limitations: - Token-only auth can call raw Proton API metadata endpoints. Decrypted Drive listing, reads, writes, and mounts need fresh login key material, so use `--username`, stored credentials, or password environment variables. +- The S3 backend currently has single-writer manifest semantics and whole-file + read/download behavior. Chunked streaming and multipart encrypted uploads are + planned for very large files. + +## Encrypted S3 Drive + +Initialize a passphrase-protected S3 drive profile: + +```sh +jdrive s3 init --bucket BUCKET --prefix jdrive --region us-east-1 +jdrive s3 profile-status +jdrive s3 unlock-test +``` + +For MinIO, Backblaze B2, Wasabi, R2, or other S3-compatible storage, add the +provider endpoint and path-style addressing when required: + +```sh +jdrive s3 init \ + --bucket BUCKET \ + --prefix jdrive \ + --endpoint https://s3.example.net \ + --region us-east-1 \ + --path-style +``` + +Use an AWS profile: + +```sh +jdrive s3 init --bucket BUCKET --aws-profile backup +``` + +Use built-in `jerboa-yubikey` PIV unlock material, not `ykman`: + +```sh +jdrive s3 init --bucket BUCKET --yubikey-mode piv +``` + +That mode prompts for the S3 vault password and YubiKey PIV PIN. Later commands +need both values to unwrap the local drive key. For automation: + +```sh +export JDRIVE_VAULT_PASSWORD='...' +export JDRIVE_PIV_PIN='...' +``` + +Copy, list, read, restore, and remove files: + +```sh +jdrive s3 mkdir /backups +jdrive s3 cp ./notes.txt /backups/notes.txt +jdrive s3 cp -r ./backup-dir /backups +jdrive s3 ls /backups +jdrive s3 cat /backups/notes.txt +jdrive s3 get /backups/notes.txt ./notes-restored.txt +jdrive s3 rm -r /backups/backup-dir +``` + +The bucket sees opaque object keys and encrypted bytes. Filenames and directory +structure live in the encrypted manifest. ## Install Layout --- a/protonstorage/cli.ss +++ b/protonstorage/cli.ss @@ -23,6 +23,7 @@ (protonstorage drive local) (protonstorage drive write) (protonstorage s3 config) + (protonstorage s3 drive) (jerboa-fuse) (only (proton-bridge api session) proton-session-base-url @@ -44,6 +45,9 @@ " creds store Store encrypted username/password\n" " mount --mountpoint M Mount decrypted Drive tree\n" " s3 status Show S3 backend configuration\n" + " s3 init --bucket B Create encrypted S3 drive profile\n" + " s3 cp [-r] LOCAL REMOTE Copy local data to encrypted S3 drive\n" + " s3 ls [REMOTE] List encrypted S3 drive manifest\n" " doctor Show implementation status\n" "\n" "If a profile credential vault exists and no token/username is provided,\n" @@ -72,6 +76,15 @@ " drive status Show native Drive API surface\n" " s3 status Show S3 backend config without secrets\n" " s3 target --bucket B --key K Show S3 object request target\n" + " s3 init --bucket B Store encrypted S3 drive key in ~/.jdrive\n" + " s3 profile-status Show local encrypted S3 profile state\n" + " s3 unlock-test Verify S3 profile password/YubiKey unlock\n" + " s3 cp [-r] LOCAL REMOTE Upload a file/tree to encrypted S3\n" + " s3 ls [REMOTE] List encrypted S3 paths\n" + " s3 mkdir REMOTE Create encrypted S3 directory marker\n" + " s3 cat REMOTE Write decrypted remote bytes to stdout\n" + " s3 get REMOTE LOCAL Download decrypted remote file\n" + " s3 rm [-r] REMOTE Delete encrypted remote file/tree\n" " drive login --username USER Fresh SRP/FIDO2 login probe\n" " drive user Fetch Proton user/quota JSON\n" " drive salts Fetch Proton key salts\n" @@ -169,7 +182,13 @@ " --endpoint URL Or JDRIVE_S3_ENDPOINT, default s3.amazonaws.com\n" " --region R Or AWS_REGION/AWS_DEFAULT_REGION\n" " --aws-profile P Or AWS_PROFILE\n" - " --path-style Or JDRIVE_S3_PATH_STYLE=1\n")) + " --path-style Or JDRIVE_S3_PATH_STYLE=1\n" + " --profile P Local S3 profile, default default\n" + " --state-dir PATH Local S3 state root, default ~/.jdrive\n" + " --vault-password-env ENV Read S3 drive vault password from env\n" + " --yubikey-mode none|piv Optional PIV-backed vault unlock\n" + " --piv-pin-env ENV Read YubiKey PIV PIN from env\n" + " -r, --recursive Recursive S3 cp/rm\n")) (define (println s) (display s) @@ -252,7 +271,14 @@ ("--region" . #t) ("--aws-profile" . #t) ("--path-style" . #f) - ("--key" . #t))) + ("--key" . #t) + ("--profile" . #t) + ("--state-dir" . #t) + ("--vault-password-env" . #t) + ("--yubikey-mode" . #t) + ("--piv-pin-env" . #t) + ("-r" . #f) + ("--recursive" . #f))) (define (split-opts args known-flags) (let loop ([xs args] [opts '()] [pos '()]) @@ -1033,9 +1059,70 @@ [else (die 2 (string-append "unknown drive credentials subcommand: " action))])))))) + (define (truthy-env? value) + (and value + (not (string=? value "")) + (not (string=? value "0")) + (not (string-ci=? value "false")) + (not (string-ci=? value "no")))) + + (define (s3-vault-password-from-opts opts) + (or (read-env-name-option opts "--vault-password-env") + (env-or "JDRIVE_S3_VAULT_PASSWORD" "JDRIVE_VAULT_PASSWORD") + (read-secret "S3 drive vault password: "))) + + (define (s3-confirm-vault-password opts) + (let ([password (s3-vault-password-from-opts opts)]) + (unless (or (opt opts "--vault-password-env") + (env-or "JDRIVE_S3_VAULT_PASSWORD" "JDRIVE_VAULT_PASSWORD")) + (let ([again (read-secret "Confirm S3 drive vault password: ")]) + (unless (string=? password again) + (die 2 "S3 drive vault passwords did not match")))) + password)) + + (define (s3-yubikey-mode opts default) + (let ([mode (or (opt opts "--yubikey-mode") + (env-or "JDRIVE_YUBIKEY_MODE") + default + "none")]) + (cond + [(string-ci=? mode "none") "none"] + [(string-ci=? mode "piv") "piv"] + [else (die 2 "S3 --yubikey-mode must be none or piv")]))) + + (define (s3-piv-pin-from-opts opts) + (or (read-env-name-option opts "--piv-pin-env") + (env-or "JDRIVE_PIV_PIN") + (read-secret "YubiKey PIV PIN: "))) + + (define (s3-yubikey-material-for-mode opts mode) + (cond + [(string=? mode "none") #vu8()] + [(string=? mode "piv") + (jdrive-s3-yubikey-piv-unlock-material (s3-piv-pin-from-opts opts))] + [else (die 2 "S3 --yubikey-mode must be none or piv")])) + + (define (s3-yubikey-material-for-profile opts) + (let* ([status + (jdrive-s3-profile-status-json + (profile-option opts) + (state-root-option opts))] + [stored-mode (hashtable-ref status "YubiKeyMode" "none")] + [mode (s3-yubikey-mode opts stored-mode)]) + (s3-yubikey-material-for-mode opts mode))) + + (define (s3-required-bucket opts) + (or (opt opts "--bucket") + (env-or "JDRIVE_S3_BUCKET") + (die 2 "s3 init requires --bucket or JDRIVE_S3_BUCKET"))) + + (define (s3-path-style? opts) + (or (opt opts "--path-style") + (truthy-env? (env-or "JDRIVE_S3_PATH_STYLE")))) + (define (cmd-s3 args) (if (null? args) - (die 2 "s3 requires a subcommand: status, target") + (die 2 "s3 requires a subcommand: status, target, init, profile-status, unlock-test, cp, ls, mkdir, cat, get, rm") (let ([action (car args)]) (call-with-values (lambda () (split-opts (cdr args) s3-flags)) @@ -1045,6 +1132,13 @@ (unless (null? pos) (die 2 "s3 status uses named options only")) (print-json (jdrive-s3-status-json opts))] + [(string=? action "profile-status") + (unless (null? pos) + (die 2 "s3 profile-status uses named options only")) + (print-json + (jdrive-s3-profile-status-json + (profile-option opts) + (state-root-option opts)))] [(string=? action "target") (let ([bucket (or (opt opts "--bucket") (env-or "JDRIVE_S3_BUCKET"))] @@ -1061,6 +1155,130 @@ (unless key (die 2 "usage: jdrive s3 target --bucket B --key K")) (print-json (jdrive-s3-target-json opts key)))] + [(string=? action "init") + (unless (null? pos) + (die 2 "s3 init uses named options only")) + (let* ([mode (s3-yubikey-mode opts "none")] + [material (s3-yubikey-material-for-mode opts mode)]) + (print-json + (jdrive-s3-init-profile! + (profile-option opts) + (state-root-option opts) + (s3-required-bucket opts) + (or (opt opts "--prefix") + (env-or "JDRIVE_S3_PREFIX") + "jdrive") + (or (opt opts "--endpoint") + (env-or "JDRIVE_S3_ENDPOINT") + "s3.amazonaws.com") + (or (opt opts "--region") + (env-or "AWS_REGION" "AWS_DEFAULT_REGION") + "us-east-1") + (or (opt opts "--aws-profile") + (env-or "AWS_PROFILE") + "") + (s3-path-style? opts) + (s3-confirm-vault-password opts) + mode + material)))] + [(string=? action "unlock-test") + (unless (null? pos) + (die 2 "s3 unlock-test uses named options only")) + (let* ([password (s3-vault-password-from-opts opts)] + [material (s3-yubikey-material-for-profile opts)]) + (call-with-values + (lambda () + (jdrive-s3-load-profile + (profile-option opts) + (state-root-option opts) + password + material)) + (lambda (config vault drive-key) + (print-json + (json-object + "Backend" "s3" + "Unlocked" #t + "Profile" (jdrive-s3-profile-name (profile-option opts)) + "Bucket" (hashtable-ref config "Bucket" "") + "Prefix" (hashtable-ref config "Prefix" "") + "YubiKeyMode" (hashtable-ref vault "YubiKeyMode" "none"))))))] + [(string=? action "ls") + (when (> (length pos) 1) + (die 2 "usage: jdrive s3 ls [REMOTE_PATH]")) + (let* ([password (s3-vault-password-from-opts opts)] + [material (s3-yubikey-material-for-profile opts)]) + (print-json + (jdrive-s3-list! + (profile-option opts) + (state-root-option opts) + password + material + (if (null? pos) "/" (car pos)))))] + [(string=? action "mkdir") + (unless (= (length pos) 1) + (die 2 "usage: jdrive s3 mkdir REMOTE_PATH")) + (let* ([password (s3-vault-password-from-opts opts)] + [material (s3-yubikey-material-for-profile opts)]) + (print-json + (jdrive-s3-mkdir! + (profile-option opts) + (state-root-option opts) + password + material + (car pos))))] + [(or (string=? action "cp") (string=? action "put")) + (unless (= (length pos) 2) + (die 2 "usage: jdrive s3 cp [-r] LOCAL_PATH REMOTE_PATH")) + (let* ([password (s3-vault-password-from-opts opts)] + [material (s3-yubikey-material-for-profile opts)]) + (print-json + (jdrive-s3-put-local-path! + (profile-option opts) + (state-root-option opts) + password + material + (car pos) + (cadr pos) + (recursive-upload? opts))))] + [(string=? action "cat") + (unless (= (length pos) 1) + (die 2 "usage: jdrive s3 cat REMOTE_PATH")) + (let* ([password (s3-vault-password-from-opts opts)] + [material (s3-yubikey-material-for-profile opts)]) + (put-bytevector + (current-output-port) + (jdrive-s3-cat-file-bytes + (profile-option opts) + (state-root-option opts) + password + material + (car pos))))] + [(string=? action "get") + (unless (= (length pos) 2) + (die 2 "usage: jdrive s3 get REMOTE_PATH LOCAL_PATH")) + (let* ([password (s3-vault-password-from-opts opts)] + [material (s3-yubikey-material-for-profile opts)]) + (print-json + (jdrive-s3-get-file! + (profile-option opts) + (state-root-option opts) + password + material + (car pos) + (cadr pos))))] + [(or (string=? action "rm") (string=? action "delete")) + (unless (= (length pos) 1) + (die 2 "usage: jdrive s3 rm [-r] REMOTE_PATH")) + (let* ([password (s3-vault-password-from-opts opts)] + [material (s3-yubikey-material-for-profile opts)]) + (print-json + (jdrive-s3-remove! + (profile-option opts) + (state-root-option opts) + password + material + (car pos) + (recursive-upload? opts))))] [else (die 2 (string-append "unknown s3 subcommand: " action))])))))) new file mode 100644 --- /dev/null +++ b/protonstorage/s3/drive.ss @@ -0,0 +1,937 @@ +#!chezscheme +;;; (protonstorage s3 drive) - encrypted S3-backed jdrive profile. + +(library (protonstorage s3 drive) + (export + jdrive-s3-local-state-root + jdrive-s3-profile-name + jdrive-s3-profile-paths + jdrive-s3-profile-status-json + jdrive-s3-yubikey-piv-unlock-material + jdrive-s3-init-profile! + jdrive-s3-load-profile + jdrive-s3-object-id + jdrive-s3-encrypt-file-bytes + jdrive-s3-decrypt-file-bytes + jdrive-s3-empty-manifest + jdrive-s3-manifest-add-directory + jdrive-s3-manifest-add-file + jdrive-s3-manifest-list + jdrive-s3-list! + jdrive-s3-mkdir! + jdrive-s3-put-local-path! + jdrive-s3-cat-file-bytes + jdrive-s3-get-file! + jdrive-s3-remove!) + + (import (except (chezscheme) + make-hash-table hash-table? + sort sort! + printf fprintf + path-extension path-absolute? + with-input-from-string with-output-to-string + iota 1+ 1- + partition + make-date make-time) + (only (std text json) json-object->string string->json-object) + (only (std text base64) base64-string->u8vector u8vector->base64-string) + (jerboa-crypto) + (yubikey auth) + (jerboa-aws s3 api) + (jerboa-aws s3 objects) + (protonstorage s3 config)) + + (define profile-version 1) + (define vault-version 1) + (define vault-cipher "chacha20-poly1305") + (define vault-kdf "scrypt") + (define vault-scrypt-N 32768) + (define vault-scrypt-r 8) + (define vault-scrypt-p 1) + (define manifest-magic (string->utf8 "JDRIVE-MANIFEST-V1\n")) + (define file-magic (string->utf8 "JDRIVE-FILE-V1\n")) + (define file-content-type "application/octet-stream") + (define s3-retry-count 3) + + (define (json-object . fields) + (let ([ht (make-hashtable equal-hash equal?)]) + (let loop ([xs fields]) + (unless (null? xs) + (hashtable-set! ht (car xs) (cadr xs)) + (loop (cddr xs)))) + ht)) + + (define (jref who obj key) + (unless (hashtable? obj) + (error who "expected JSON object")) + (let ([value (hashtable-ref obj key #f)]) + (unless value + (error who "missing JSON field" key)) + value)) + + (define (jmaybe obj key default) + (if (hashtable? obj) + (hashtable-ref obj key default) + default)) + + (define (nonempty-string who field value) + (unless (and (string? value) (> (string-length value) 0)) + (error who "expected nonempty string" field)) + value) + + (define (string-present? value) + (and (string? value) (> (string-length value) 0))) + + (define (safe-profile-char? ch) + (or (char-alphabetic? ch) + (char-numeric? ch) + (char=? ch #\-) + (char=? ch #\_) + (char=? ch #\.))) + + (define (safe-profile-name? name) + (and (string-present? name) + (not (string=? name ".")) + (not (string=? name "..")) + (let loop ([i 0]) + (or (= i (string-length name)) + (and (safe-profile-char? (string-ref name i)) + (loop (+ i 1))))))) + + (define (jdrive-s3-profile-name explicit) + (let ([name (or (and (string-present? explicit) explicit) + (and (string-present? (getenv "JDRIVE_PROFILE")) + (getenv "JDRIVE_PROFILE")) + "default")]) + (unless (safe-profile-name? name) + (error 'jdrive-s3-profile-name + "profile names may contain only letters, digits, '.', '-', and '_'" + name)) + name)) + + (define (string-suffix? s suffix) + (let ([n (string-length s)] + [m (string-length suffix)]) + (and (>= n m) + (string=? (substring s (- n m) n) suffix)))) + + (define (trim-trailing-slash path) + (let loop ([end (string-length path)]) + (cond + [(<= end 1) (substring path 0 end)] + [(char=? (string-ref path (- end 1)) #\/) (loop (- end 1))] + [else (substring path 0 end)]))) + + (define (strip-leading-slashes path) + (let loop ([start 0]) + (if (and (< start (string-length path)) + (char=? (string-ref path start) #\/)) + (loop (+ start 1)) + (substring path start (string-length path))))) + + (define (path-join base name) + (let ([base (trim-trailing-slash base)]) + (cond + [(= (string-length base) 0) name] + [(string-suffix? base "/") (string-append base name)] + [else (string-append base "/" name)]))) + + (define (jdrive-s3-local-state-root explicit) + (or (and (string-present? explicit) explicit) + (and (string-present? (getenv "JDRIVE_STATE_DIR")) + (getenv "JDRIVE_STATE_DIR")) + (let ([home (getenv "HOME")]) + (and (string-present? home) (path-join home ".jdrive"))) + ".jdrive")) + + (define (profile-root state-root profile) + (path-join (path-join state-root "profiles") profile)) + + (define (jdrive-s3-profile-paths profile state-root) + (let* ([profile (jdrive-s3-profile-name profile)] + [state-root (jdrive-s3-local-state-root state-root)] + [root (profile-root state-root profile)]) + (json-object + "Profile" profile + "StateRoot" state-root + "ProfileRoot" root + "ConfigFile" (path-join root "s3.config.json") + "VaultFile" (path-join root "s3.key.vault.json")))) + + (define (last-slash-index path) + (let loop ([i (- (string-length path) 1)]) + (cond + [(< i 0) #f] + [(char=? (string-ref path i) #\/) i] + [else (loop (- i 1))]))) + + (define (parent-directory path) + (let ([path (trim-trailing-slash path)]) + (cond + [(or (= (string-length path) 0) (string=? path ".")) "."] + [(string=? path "/") "/"] + [else + (let ([slash (last-slash-index path)]) + (cond + [(not slash) "."] + [(= slash 0) "/"] + [else (substring path 0 slash)]))]))) + + (define (ensure-directory! path) + (unless (file-directory? path) + (let ([parent (parent-directory path)]) + (unless (or (string=? parent path) + (file-directory? parent)) + (ensure-directory! parent))) + (guard (e [#t + (unless (file-directory? path) + (raise e))]) + (mkdir path)))) + + (define (read-file-string path) + (call-with-input-file path get-string-all)) + + (define (write-file-string path text) + (ensure-directory! (parent-directory path)) + (call-with-output-file path (lambda (p) (display text p)) 'replace)) + + (define (read-file-bytes path) + (call-with-port (open-file-input-port path) + (lambda (p) (get-bytevector-all p)))) + + (define (write-file-bytes path data) + (ensure-directory! (parent-directory path)) + (call-with-port + (open-file-output-port path (file-options no-fail) (buffer-mode block)) + (lambda (p) (put-bytevector p data)))) + + (define (bytevector-prefix? prefix bv) + (let ([n (bytevector-length prefix)] + [m (bytevector-length bv)]) + (and (>= m n) + (let loop ([i 0]) + (or (= i n) + (and (= (bytevector-u8-ref prefix i) + (bytevector-u8-ref bv i)) + (loop (+ i 1)))))))) + + (define (jdrive-bytevector-slice bv start end) + (let* ([len (- end start)] + [out (make-bytevector len 0)]) + (let loop ([i 0]) + (when (< i len) + (bytevector-u8-set! out i (bytevector-u8-ref bv (+ start i))) + (loop (+ i 1)))) + out)) + + (define (bytevectors-length bvs) + (let loop ([xs bvs] [n 0]) + (if (null? xs) + n + (loop (cdr xs) (+ n (bytevector-length (car xs))))))) + + (define (bytevectors-append . bvs) + (let* ([total (bytevectors-length bvs)] + [out (make-bytevector total 0)]) + (let outer ([xs bvs] [offset 0]) + (unless (null? xs) + (let* ([bv (car xs)] + [len (bytevector-length bv)]) + (let inner ([i 0]) + (when (< i len) + (bytevector-u8-set! out (+ offset i) (bytevector-u8-ref bv i)) + (inner (+ i 1)))) + (outer (cdr xs) (+ offset len))))) + out)) + + (define hex-digits "0123456789abcdef") + + (define (bytevector->hex bv) + (let* ([n (bytevector-length bv)] + [out (make-string (* n 2))]) + (let loop ([i 0]) + (when (< i n) + (let ([b (bytevector-u8-ref bv i)]) + (string-set! out (* i 2) + (string-ref hex-digits (quotient b 16))) + (string-set! out (+ (* i 2) 1) + (string-ref hex-digits (modulo b 16)))) + (loop (+ i 1)))) + out)) + + (define (vault-aad) + (string->utf8 "jerboa-drive s3 key vault v1")) + + (define (join-unlock-material password yubikey-material) + (bytevectors-append + (string->utf8 (nonempty-string 'join-unlock-material 'password password)) + #vu8(0) + (cond + [(bytevector? yubikey-material) yubikey-material] + [(string? yubikey-material) (string->utf8 yubikey-material)] + [else #vu8()]))) + + (define (derive-vault-key password yubikey-material salt) + (scrypt + (join-unlock-material password yubikey-material) + salt + 32 + vault-scrypt-N + vault-scrypt-r + vault-scrypt-p)) + + (define (jdrive-s3-yubikey-piv-unlock-material pin) + (string->utf8 + (yubikey-piv-derive-password + (nonempty-string 'jdrive-s3-yubikey-piv-unlock-material 'pin pin) + 'length: 64))) + + (define (vault-yubikey-mode vault) + (or (jmaybe vault "YubiKeyMode" "none") "none")) + + (define (wrap-drive-key drive-key password yubikey-mode yubikey-material) + (let* ([salt (random-bytes 16)] + [nonce (random-bytes 12)] + [key (derive-vault-key password yubikey-material salt)]) + (call-with-values + (lambda () (aead-encrypt vault-cipher key nonce drive-key (vault-aad))) + (lambda (ciphertext tag) + (json-object + "Version" vault-version + "KDF" vault-kdf + "Cipher" vault-cipher + "ScryptN" vault-scrypt-N + "ScryptR" vault-scrypt-r + "ScryptP" vault-scrypt-p + "YubiKeyMode" (or yubikey-mode "none") + "Salt" (u8vector->base64-string salt) + "Nonce" (u8vector->base64-string nonce) + "Tag" (u8vector->base64-string tag) + "Ciphertext" (u8vector->base64-string ciphertext)))))) + + (define (unwrap-drive-key vault password yubikey-material) + (let* ([version (jref 'unwrap-drive-key vault "Version")] + [cipher (jref 'unwrap-drive-key vault "Cipher")] + [kdf (jref 'unwrap-drive-key vault "KDF")] + [salt (base64-string->u8vector (jref 'unwrap-drive-key vault "Salt"))] + [nonce (base64-string->u8vector (jref 'unwrap-drive-key vault "Nonce"))] + [tag (base64-string->u8vector (jref 'unwrap-drive-key vault "Tag"))] + [ciphertext + (base64-string->u8vector + (jref 'unwrap-drive-key vault "Ciphertext"))]) + (unless (= version vault-version) + (error 'unwrap-drive-key "unsupported vault version" version)) + (unless (string=? cipher vault-cipher) + (error 'unwrap-drive-key "unsupported vault cipher" cipher)) + (unless (string=? kdf vault-kdf) + (error 'unwrap-drive-key "unsupported vault KDF" kdf)) + (aead-decrypt + vault-cipher + (derive-vault-key password yubikey-material salt) + nonce + ciphertext + tag + (vault-aad)))) + + (define (seal-bytes magic drive-key aad plaintext) + (let ([nonce (random-bytes 12)]) + (call-with-values + (lambda () (aead-encrypt vault-cipher drive-key nonce plaintext aad)) + (lambda (ciphertext tag) + (bytevectors-append magic nonce tag ciphertext))))) + + (define (open-sealed-bytes who magic drive-key aad sealed) + (let* ([magic-len (bytevector-length magic)] + [nonce-start magic-len] + [tag-start (+ nonce-start 12)] + [cipher-start (+ tag-start 16)] + [sealed-len (bytevector-length sealed)]) + (unless (and (>= sealed-len cipher-start) + (bytevector-prefix? magic sealed)) + (error who "invalid encrypted object envelope")) + (let ([nonce (jdrive-bytevector-slice sealed nonce-start tag-start)] + [tag (jdrive-bytevector-slice sealed tag-start cipher-start)] + [ciphertext (jdrive-bytevector-slice sealed cipher-start sealed-len)]) + (aead-decrypt vault-cipher drive-key nonce ciphertext tag aad)))) + + (define (manifest-aad) + (string->utf8 "jerboa-drive s3 manifest v1")) + + (define (file-aad path object-id) + (string->utf8 (string-append "jerboa-drive s3 file v1\n" path "\n" object-id))) + + (define (config-object bucket prefix endpoint region aws-profile path-style?) + (json-object + "Version" profile-version + "Backend" "s3" + "Bucket" (nonempty-string 'config-object 'bucket bucket) + "Prefix" (or prefix "jdrive") + "Endpoint" (or endpoint "s3.amazonaws.com") + "Region" (or region "us-east-1") + "AWSProfile" (or aws-profile "") + "PathStyle" (if path-style? #t #f))) + + (define (jdrive-s3-profile-status-json profile state-root) + (let* ([paths (jdrive-s3-profile-paths profile state-root)] + [config-file (jref 'jdrive-s3-profile-status-json paths "ConfigFile")] + [vault-file (jref 'jdrive-s3-profile-status-json paths "VaultFile")] + [config (and (file-exists? config-file) + (string->json-object (read-file-string config-file)))] + [vault (and (file-exists? vault-file) + (string->json-object (read-file-string vault-file)))]) + (json-object + "Profile" (jref 'jdrive-s3-profile-status-json paths "Profile") + "StateRoot" (jref 'jdrive-s3-profile-status-json paths "StateRoot") + "Configured" (if config #t #f) + "VaultStored" (if vault #t #f) + "YubiKeyMode" (if vault (vault-yubikey-mode vault) "none") + "Bucket" (if config (jmaybe config "Bucket" "") "") + "Prefix" (if config (jmaybe config "Prefix" "") "") + "Endpoint" (if config (jmaybe config "Endpoint" "") "") + "Region" (if config (jmaybe config "Region" "") "") + "AWSProfile" (if config (jmaybe config "AWSProfile" "") "") + "PathStyle" (if config (jmaybe config "PathStyle" #f) #f) + "ConfigFile" config-file + "VaultFile" vault-file))) + + (define (jdrive-s3-init-profile! + profile state-root bucket prefix endpoint region aws-profile path-style? + vault-password yubikey-mode yubikey-material) + (let* ([paths (jdrive-s3-profile-paths profile state-root)] + [root (jref 'jdrive-s3-init-profile! paths "ProfileRoot")] + [config-file (jref 'jdrive-s3-init-profile! paths "ConfigFile")] + [vault-file (jref 'jdrive-s3-init-profile! paths "VaultFile")] + [config (config-object bucket prefix endpoint region aws-profile path-style?)] + [drive-key (random-bytes 32)] + [vault + (wrap-drive-key + drive-key + vault-password + (or yubikey-mode "none") + yubikey-material)]) + (ensure-directory! root) + (write-file-string config-file (json-object->string config)) + (write-file-string vault-file (json-object->string vault)) + (jdrive-s3-profile-status-json profile state-root))) + + (define (jdrive-s3-load-profile profile state-root vault-password yubikey-material) + (let* ([paths (jdrive-s3-profile-paths profile state-root)] + [config-file (jref 'jdrive-s3-load-profile paths "ConfigFile")] + [vault-file (jref 'jdrive-s3-load-profile paths "VaultFile")]) + (unless (file-exists? config-file) + (error 'jdrive-s3-load-profile "S3 profile config does not exist" config-file)) + (unless (file-exists? vault-file) + (error 'jdrive-s3-load-profile "S3 key vault does not exist" vault-file)) + (let* ([config (string->json-object (read-file-string config-file))] + [vault (string->json-object (read-file-string vault-file))] + [drive-key (unwrap-drive-key vault vault-password yubikey-material)]) + (values config vault drive-key)))) + + (define (config-ref config key default) + (jmaybe config key default)) + + (define (s3-client-from-config config) + (let ([aws-profile (config-ref config "AWSProfile" "")] + [endpoint (config-ref config "Endpoint" "s3.amazonaws.com")] + [region (config-ref config "Region" "us-east-1")] + [path-style? (config-ref config "PathStyle" #f)]) + (S3Client + 'profile: (and (string-present? aws-profile) aws-profile) + 'endpoint: endpoint + 'region: region + 'path-style: path-style?))) + + (define (bucket-from-config config) + (nonempty-string 'bucket-from-config 'bucket (config-ref config "Bucket" ""))) + + (define (remote-object-key config key) + (jdrive-s3-object-key (config-ref config "Prefix" "jdrive") key)) + + (define (manifest-object-key config) + (remote-object-key config "v1/manifest.bin")) + + (define (object-storage-key config object-id) + (remote-object-key config (string-append "v1/objects/" object-id ".bin"))) + + (define (remote-path-normalize path) + (let ([path (nonempty-string 'remote-path-normalize 'path path)]) + (let ([path + (if (char=? (string-ref path 0) #\/) + path + (string-append "/" path))]) + (let ([trimmed (trim-trailing-slash path)]) + (if (= (string-length trimmed) 0) "/" trimmed))))) + + (define (remote-dir-normalize path) + (let ([path (remote-path-normalize path)]) + (if (string=? path "/") "/" (trim-trailing-slash path)))) + + (define (remote-path-join parent name) + (cond + [(string=? parent "/") (string-append "/" name)] + [else (string-append (trim-trailing-slash parent) "/" name)])) + + (define (path-basename path) + (let loop ([i (- (string-length path) 1)] [end (string-length path)]) + (cond + [(< i 0) (substring path 0 end)] + [(char=? (string-ref path i) #\/) + (if (= (+ i 1) end) + (loop (- i 1) i) + (substring path (+ i 1) end))] + [else (loop (- i 1) end)]))) + + (define (path-looks-like-directory? path) + (and (string-present? path) + (char=? (string-ref path (- (string-length path) 1)) #\/)))