Add Proton message decryption command
ober
0a05633ffffed304c0cb59f3996dcdb008cc12a2
--- a/README.md +++ b/README.md @@ -86,6 +86,7 @@ make run ARGS='login --username USER' make run ARGS='folders --username USER' make run ARGS='list --username USER --folder INBOX --limit 20' make run ARGS='message-json --username USER --id MESSAGE_ID' +make run ARGS='show --username USER --id MESSAGE_ID' make run ARGS='login --auth-info auth-info.json --username USER' make run ARGS='login --auth-options auth-options.json' ``` @@ -95,13 +96,14 @@ proof, verifies Proton's `ServerProof`, and then submits a YubiKey-backed FIDO2 assertion when Proton requires FIDO2. It prints only the authenticated UID and does not persist the session. -The read-only `folders`, `list`, and `message-json` commands perform a fresh -interactive auth for each invocation. They fetch Proton API JSON directly and -do not store a reusable refresh token or local IMAP password. +The read-only `folders`, `list`, `message-json`, and `show` commands perform +a fresh interactive auth for each invocation. They fetch Proton API JSON +directly and do not store a reusable refresh token or local IMAP password. The native helper also derives Proton's salted mailbox key passphrase from -`/core/v4/keys/salts`; this is the key-unlock input required before decrypted -message rendering can be enabled. +`/core/v4/keys/salts`, decrypts Proton address-key tokens as binary +passphrases, verifies token signatures, and decrypts selected OpenPGP message +bodies. `show` renders the best text body through `jerboa-mail`. `auth-info.json` is the `/auth/v4/info` response. The command prompts for the Proton password and emits the SRP `/auth/v4` request body plus the expected @@ -109,4 +111,4 @@ server proof to verify after Proton responds. `auth-options.json` may contain either the raw Proton `AuthenticationOptions` object or the full auth JSON containing -`2FA.FIDO2.AuthenticationOptions`. Full SRP login is the next phase. +`2FA.FIDO2.AuthenticationOptions`. --- a/plan.md +++ b/plan.md @@ -279,6 +279,10 @@ Done: `go-proton-api`. - Jerboa wrapper `proton-mailbox-password` with a deterministic Proton test vector. +- Native OpenPGP helper decrypts Proton address-key tokens as bytevector + passphrases and verifies their detached signatures before use. +- Jerboa key-selection code unlocks direct user/address keys and token-gated + address keys without writing key material to disk. Exit criteria: @@ -314,6 +318,13 @@ Deliverables: - Decrypt selected body. - Render with `jerboa-mail`. +Done: + +- `show --username USER --id MESSAGE_ID` fetches the user, salts, addresses, + and message after fresh auth. +- Message bodies are decrypted with the selected Proton key and rendered + through `jerboa-mail`. + Exit criteria: - `show --folder INBOX --id ...` prints a readable message. --- a/proton-bridge-native/Cargo.lock +++ b/proton-bridge-native/Cargo.lock @@ -1209,6 +1209,7 @@ name = "proton-bridge-native" version = "0.1.0" dependencies = [ "base64", + "pgp", "proton-srp", "zeroize", ] --- a/proton-bridge-native/Cargo.toml +++ b/proton-bridge-native/Cargo.toml @@ -10,5 +10,6 @@ crate-type = ["cdylib", "rlib"] [dependencies] base64 = "0.22" +pgp = "0.19" proton-srp = "0.8.2" zeroize = "1.8" --- a/proton-bridge-native/src/lib.rs +++ b/proton-bridge-native/src/lib.rs @@ -1,6 +1,9 @@ use base64::{engine::general_purpose::STANDARD as BASE64_STANDARD, Engine as _}; +use pgp::composed::{Deserializable, DetachedSignature, Message, SignedSecretKey}; +use pgp::types::Password; use proton_srp::{mailbox_password_hash, SRPAuth, SRPProofB64, SrpHashVersion}; use std::ffi::CStr; +use std::io::Read; use std::os::raw::c_char; use std::slice; use std::sync::{Mutex, OnceLock}; @@ -50,7 +53,18 @@ unsafe fn cstr_arg(name: &str, value: *const c_char) -> Result<String, i32> { } } -unsafe fn write_string(value: &str, out: *mut u8, out_len: *mut u32) -> Result<(), i32> { +unsafe fn bytes_arg<'a>(name: &str, value: *const u8, len: u32) -> Result<&'a [u8], i32> { + if len == 0 { + return Ok(&[]); + } + if value.is_null() && len > 0 { + set_last_error(format!("{name} is null")); + return Err(PB_SRP_INVALID_ARGUMENT); + } + Ok(slice::from_raw_parts(value, len as usize)) +} + +unsafe fn write_bytes(value: &[u8], out: *mut u8, out_len: *mut u32) -> Result<(), i32> { if out_len.is_null() { set_last_error("output length pointer is null"); return Err(PB_SRP_INVALID_ARGUMENT); @@ -61,10 +75,58 @@ unsafe fn write_string(value: &str, out: *mut u8, out_len: *mut u32) -> Result<( if out.is_null() || cap < need { return Err(PB_SRP_INSUFFICIENT_BUFFER); } - slice::from_raw_parts_mut(out, need as usize).copy_from_slice(value.as_bytes()); + slice::from_raw_parts_mut(out, need as usize).copy_from_slice(value); Ok(()) } +unsafe fn write_string(value: &str, out: *mut u8, out_len: *mut u32) -> Result<(), i32> { + write_bytes(value.as_bytes(), out, out_len) +} + +fn parse_secret_key(secret_armor: &str) -> Result<SignedSecretKey, String> { + let (key, _) = SignedSecretKey::from_armor_single(secret_armor.as_bytes()) + .map_err(|err| err.to_string())?; + key.verify_bindings().map_err(|err| err.to_string())?; + Ok(key) +} + +fn pgp_decrypt_with_key( + key: &SignedSecretKey, + passphrase: &[u8], + cipher_armor: &str, +) -> Result<Vec<u8>, String> { + let (message, _) = + Message::from_armor(cipher_armor.as_bytes()).map_err(|err| err.to_string())?; + let password = Password::from(passphrase); + let mut decrypted = message + .decrypt(&password, key) + .map_err(|err| err.to_string())?; + let mut plaintext = Vec::new(); + decrypted + .read_to_end(&mut plaintext) + .map_err(|err| err.to_string())?; + Ok(plaintext) +} + +fn verify_detached_token_signature( + key: &SignedSecretKey, + signature_armor: &str, + token: &[u8], +) -> Result<(), String> { + let (signature, _) = DetachedSignature::from_armor_single(signature_armor.as_bytes()) + .map_err(|err| err.to_string())?; + let public_key = key.to_public_key(); + if signature.verify(&public_key.primary_key, token).is_ok() { + return Ok(()); + } + for subkey in &public_key.public_subkeys { + if signature.verify(subkey, token).is_ok() { + return Ok(()); + } + } + Err("token signature verification failed".to_owned()) +} + unsafe fn write_outputs( proof: &SRPProofB64, out_client_ephemeral: *mut u8, @@ -188,6 +250,112 @@ pub unsafe extern "C" fn pb_native_mailbox_password( } } +/// Decrypt an ASCII-armored OpenPGP message with an armored secret key. +/// +/// The passphrase is byte-oriented because Proton key tokens are binary. +#[no_mangle] +pub unsafe extern "C" fn pb_native_pgp_decrypt( + secret_armor: *const c_char, + passphrase: *const u8, + passphrase_len: u32, + cipher_armor: *const c_char, + out: *mut u8, + out_len: *mut u32, +) -> i32 { + set_last_error(""); + + let secret_armor = match cstr_arg("secret_armor", secret_armor) { + Ok(value) => value, + Err(code) => return code, + }; + let passphrase = match bytes_arg("passphrase", passphrase, passphrase_len) { + Ok(value) => value, + Err(code) => return code, + }; + let cipher_armor = match cstr_arg("cipher_armor", cipher_armor) { + Ok(value) => value, + Err(code) => return code, + }; + + let key = match parse_secret_key(&secret_armor) { + Ok(key) => key, + Err(err) => { + set_last_error(err); + return PB_SRP_ERROR; + } + }; + + match pgp_decrypt_with_key(&key, passphrase, &cipher_armor) { + Ok(plaintext) => match write_bytes(&plaintext, out, out_len) { + Ok(()) => PB_SRP_OK, + Err(code) => code, + }, + Err(err) => { + set_last_error(err); + PB_SRP_ERROR + } + } +} + +/// Decrypt and verify a Proton address-key token with a user key. +/// +/// The returned bytes are the address key passphrase. +#[no_mangle] +pub unsafe extern "C" fn pb_native_proton_token_passphrase( + user_secret_armor: *const c_char, + user_passphrase: *const u8, + user_passphrase_len: u32, + token_armor: *const c_char, + signature_armor: *const c_char, + out: *mut u8, + out_len: *mut u32, +) -> i32 { + set_last_error(""); + + let user_secret_armor = match cstr_arg("user_secret_armor", user_secret_armor) { + Ok(value) => value, + Err(code) => return code, + }; + let user_passphrase = match bytes_arg("user_passphrase", user_passphrase, user_passphrase_len) { + Ok(value) => value, + Err(code) => return code, + }; + let token_armor = match cstr_arg("token_armor", token_armor) { + Ok(value) => value, + Err(code) => return code, + }; + let signature_armor = match cstr_arg("signature_armor", signature_armor) { + Ok(value) => value, + Err(code) => return code, + }; + + let key = match parse_secret_key(&user_secret_armor) { + Ok(key) => key, + Err(err) => { + set_last_error(err); + return PB_SRP_ERROR; + } + }; + + let token = match pgp_decrypt_with_key(&key, user_passphrase, &token_armor) { + Ok(token) => token, + Err(err) => { + set_last_error(err); + return PB_SRP_ERROR; + } + }; + + if let Err(err) = verify_detached_token_signature(&key, &signature_armor, &token) { + set_last_error(err); + return PB_SRP_ERROR; + } + + match write_bytes(&token, out, out_len) { + Ok(()) => PB_SRP_OK, + Err(code) => code, + } +} + /// Generate Proton SRP authentication proofs from `/auth/v4/info` values. /// /// All string inputs must be NUL-terminated UTF-8. `salt`, --- a/proton-bridge/api/auth.ss +++ b/proton-bridge/api/auth.ss @@ -9,6 +9,7 @@ proton-auth-uid proton-auth-access-token proton-auth-refresh-token + proton-auth-password-mode proton-auth-fido2-required? proton-auth-totp-required?) @@ -94,6 +95,10 @@ (def (proton-auth-refresh-token auth) (jref 'proton-auth-refresh-token auth "RefreshToken")) + (def (proton-auth-password-mode auth) + (let ([mode (jmaybe auth "PasswordMode")]) + (if (number? mode) mode 1))) + (def (twofa-enabled auth) (let ([twofa (jmaybe auth "2FA")]) (and twofa (jmaybe twofa "Enabled")))) --- a/proton-bridge/cli.ss +++ b/proton-bridge/cli.ss @@ -19,6 +19,7 @@ (proton-bridge api http) (proton-bridge api mail) (proton-bridge api session) + (proton-bridge crypto) (proton-bridge fido2) (proton-bridge srp) (only (yubikey fido2) fido2-assertion-credential-id)) @@ -35,7 +36,7 @@ " folders List Proton folders after fresh auth\n" " list List message metadata after fresh auth\n" " message-json Fetch one raw Proton message JSON object\n" - " show Fetch/decrypt/show one message (planned)\n" + " show Fetch/decrypt/show one message after fresh auth\n" " help Print this help\n" " version Print version\n")) @@ -75,15 +76,13 @@ (if (proton-srp-native-available?) "available" "build required"))) + (println (string-append "native Proton crypto: " + (if (proton-crypto-native-available?) + "available" + "build required"))) (println "FIDO2/WebAuthn via jerboa-yubikey: payload path available") (println "password-authenticated local IMAP: intentionally disabled")) - (define (planned command) - (die 2 - (string-append - command - " is planned; native Proton auth and FIDO2 are not implemented yet"))) - (define (read-file-string path) (call-with-input-file path (lambda (port) (get-string-all port)))) @@ -129,6 +128,19 @@ (die 2 (string-append "environment variable is unset: " env-name)))] [else (read-secret "Proton password: ")]))) + (define (read-mailbox-password-from-options opts) + (let ([env-name (opt opts "--mailbox-password-env")]) + (cond + [env-name + (or (getenv env-name) + (die 2 (string-append "environment variable is unset: " env-name)))] + [else (read-secret "Proton mailbox password: ")]))) + + (define (key-pass-from-auth auth password opts) + (if (= (proton-auth-password-mode auth) 2) + (read-mailbox-password-from-options opts) + password)) + (define (auth-base-url opts) (or (opt opts "--base-url") default-proton-api-base-url)) @@ -138,7 +150,7 @@ (die 2 "auth requires --username USER")) username)) - (define (authenticated-session-from-options opts) + (define (authenticated-session+key-pass-from-options opts) (let* ([username (auth-username opts)] [base-url (auth-base-url opts)] [password (read-password-from-options opts)]) @@ -152,17 +164,25 @@ [(proton-auth-fido2-required? auth) (let ([pin (if (opt opts "--prompt-pin") (read-secret "FIDO2 PIN: ") - "")]) + "")] + [key-pass (key-pass-from-auth auth password opts)]) (eprintln "Touch your YubiKey when it blinks.") (call-with-values (lambda () (proton-fido2-assert auth 'pin: pin)) (lambda (auth-data assertion payload-json) (proton-auth-submit-fido2 auth payload-json 'base-url: base-url) - (proton-session-from-auth base-url auth))))] + (values (proton-session-from-auth base-url auth) + key-pass))))] [(proton-auth-totp-required? auth) (die 2 "TOTP 2FA is required, but TOTP submission is not implemented yet")] [else - (proton-session-from-auth base-url auth)])))))) + (values (proton-session-from-auth base-url auth) + (key-pass-from-auth auth password opts))])))))) + + (define (authenticated-session-from-options opts) + (call-with-values + (lambda () (authenticated-session+key-pass-from-options opts)) + (lambda (session key-pass) session))) (define (cmd-login-srp auth-info-file opts) (let ([username (opt opts "--username")]) @@ -287,10 +307,58 @@ [message (proton-mail-get-message session message-id)]) (println (json-object->string message))))) + (define (mail-address-list->string value) + (cond + [(not value) ""] + [(list? value) (join-strings (map mail-address->string value) ", ")] + [else (mail-address->string value)])) + + (define (print-show-heading message) + (println + (string-append "Subject: " + (json-value->string (json-ref message "Subject" "")))) + (println + (string-append "From: " + (mail-address->string (json-ref message "Sender" #f)))) + (let ([to (mail-address-list->string (json-ref message "ToList" '()))]) + (when (> (string-length to) 0) + (println (string-append "To: " to)))) + (println + (string-append "Time: " + (json-value->string (json-ref message "Time" "")))) + (println + (string-append "Message-ID: " + (json-value->string (json-ref message "ID" "")))) + (newline)) + + (define (cmd-show args) + (let* ([parsed (split-opts args auth-known-options)] + [opts (car parsed)] + [message-id (opt opts "--id")]) + (unless message-id + (die 2 "show requires --id MESSAGE_ID")) + (call-with-values + (lambda () (authenticated-session+key-pass-from-options opts)) + (lambda (session key-pass) + (eprintln "Fetching Proton user keys, salts, addresses, and message.") + (let* ([user (proton-mail-get-user session)] + [salts (proton-mail-get-salts session)] + [addresses (proton-mail-get-addresses session)] + [message (proton-mail-get-message session message-id)] + [decrypted + (proton-decrypt-message user addresses salts key-pass message)] + [body + (proton-render-decrypted-message + message + (proton-decryption-result-plaintext decrypted))]) + (print-show-heading message) + (println body)))))) + (define auth-known-options '(("--username" . #t) ("--base-url" . #t) ("--password-env" . #t) + ("--mailbox-password-env" . #t) ("--prompt-pin" . #f) ("--folder" . #t) ("--limit" . #t) @@ -303,6 +371,7 @@ ("--username" . #t) ("--base-url" . #t) ("--password-env" . #t) + ("--mailbox-password-env" . #t) ("--prompt-pin" . #f)))] [opts (car parsed)] [auth-options-file (opt opts "--auth-options")] @@ -343,7 +412,7 @@ (cmd-folders (car (split-opts (cdr args) auth-known-options)))] [(string=? (car args) "list") (cmd-list (cdr args))] [(string=? (car args) "message-json") (cmd-message-json (cdr args))] - [(string=? (car args) "show") (planned "show")] + [(string=? (car args) "show") (cmd-show (cdr args))] [else (die 2 (string-append "unknown command: " (car args)))]))) ) ;; end library new file mode 100644 --- /dev/null +++ b/proton-bridge/crypto.ss @@ -0,0 +1,413 @@ +#!chezscheme +;;; (proton-bridge crypto) - Proton key unlock and message decrypt helpers. + +(library (proton-bridge crypto) + (export + proton-crypto-native-available? + proton-crypto-pgp-decrypt + proton-crypto-token-passphrase + proton-key-active? + proton-key-primary? + proton-object-keys + proton-primary-key + proton-key-salt + proton-salted-key-pass + proton-decryption-result? + make-proton-decryption-result + proton-decryption-result-plaintext + proton-decryption-result-key-id + proton-decryption-result-key-source + proton-decrypt-message + proton-render-decrypted-message) + + (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) + (except (jerboa prelude) meta atom?) + (only (std text base64) u8vector->base64-string) + (jerboa-mail mime) + (proton-bridge srp)) + + (def PB-SRP-OK 0) + (def PB-SRP-INVALID-ARGUMENT -1) + (def PB-SRP-UNSUPPORTED-VERSION -2) + (def PB-SRP-ERROR -3) + (def PB-SRP-INSUFFICIENT-BUFFER -4) + + (defstruct proton-decryption-result + (plaintext key-id key-source)) + + (define *native-paths* + '("libproton_bridge_native.so" + "libproton_bridge_native.dylib" + "proton-bridge-native/target/release/libproton_bridge_native.so" + "proton-bridge-native/target/release/libproton_bridge_native.dylib" + "./proton-bridge-native/target/release/libproton_bridge_native.so" + "./proton-bridge-native/target/release/libproton_bridge_native.dylib" + "proton-bridge-native/target/debug/libproton_bridge_native.so" + "proton-bridge-native/target/debug/libproton_bridge_native.dylib" + "./proton-bridge-native/target/debug/libproton_bridge_native.so" + "./proton-bridge-native/target/debug/libproton_bridge_native.dylib")) + + (define *native-loaded?* + (let loop ([ps *native-paths*]) + (cond + [(null? ps) #f] + [(guard (e [#t #f]) + (load-shared-object (car ps)) #t) + #t] + [else (loop (cdr ps))]))) + + (define c-pgp-decrypt + (and *native-loaded?* + (guard (e [#t #f]) + (foreign-procedure "pb_native_pgp_decrypt" + (string u8* unsigned-32 string u8* u8*) + integer-32)))) + + (define c-token-passphrase + (and *native-loaded?* + (guard (e [#t #f]) + (foreign-procedure "pb_native_proton_token_passphrase" + (string u8* unsigned-32 string string u8* u8*) + integer-32)))) + + (def (proton-crypto-native-available?) + (and *native-loaded?* c-pgp-decrypt c-token-passphrase)) + + (def (u32-le-ref bv off) + (+ (bytevector-u8-ref bv off) + (* 256 (bytevector-u8-ref bv (+ off 1))) + (* 65536 (bytevector-u8-ref bv (+ off 2))) + (* 16777216 (bytevector-u8-ref bv (+ off 3))))) + + (def (u32-le-set! bv off n) + (do ([i 0 (+ i 1)] + [v n (bitwise-arithmetic-shift-right v 8)]) + [(= i 4)] + (bytevector-u8-set! bv (+ off i) (bitwise-and v #xff)))) + + (def (bv-slice bv start end) + (let* ([n (- end start)] + [out (make-bytevector n 0)]) + (bytevector-copy! bv start out 0 n) + out)) + + (def (check-native who) + (unless (proton-crypto-native-available?) + (error who "native Proton crypto backend not loaded; run `make native` first"))) + + (def (call-native-bytes who initial-size thunk) + (let* ([out (make-bytevector initial-size 0)] + [len (make-bytevector 4 0)]) + (u32-le-set! len 0 initial-size) + (let ([rc (thunk out len)]) + (cond + [(= rc PB-SRP-OK) + (bv-slice out 0 (u32-le-ref len 0))] + [(= rc PB-SRP-INSUFFICIENT-BUFFER) + (let* ([needed (u32-le-ref len 0)] + [out2 (make-bytevector needed 0)] + [len2 (make-bytevector 4 0)]) + (u32-le-set! len2 0 needed) + (let ([rc2 (thunk out2 len2)]) + (if (= rc2 PB-SRP-OK) + (bv-slice out2 0 (u32-le-ref len2 0)) + (error who (proton-srp-error-string rc2)))))] + [else + (error who (proton-srp-error-string rc))])))) + + (def (proton-crypto-pgp-decrypt secret-armor passphrase-bv cipher-armor) + (check-native 'proton-crypto-pgp-decrypt) + (unless (bytevector? passphrase-bv) + (error 'proton-crypto-pgp-decrypt "passphrase must be a bytevector")) + (call-native-bytes + 'proton-crypto-pgp-decrypt + 65536 + (lambda (out len) + (c-pgp-decrypt secret-armor + passphrase-bv + (bytevector-length passphrase-bv) + cipher-armor + out + len)))) + + (def (proton-crypto-token-passphrase user-secret-armor user-passphrase-bv + token-armor signature-armor) + (check-native 'proton-crypto-token-passphrase) + (unless (bytevector? user-passphrase-bv) + (error 'proton-crypto-token-passphrase "passphrase must be a bytevector")) + (call-native-bytes + 'proton-crypto-token-passphrase + 256 + (lambda (out len) + (c-token-passphrase user-secret-armor + user-passphrase-bv + (bytevector-length user-passphrase-bv) + token-armor + signature-armor + out + len)))) + + (define *missing* (list 'missing)) + + (def (jmaybe obj key . default) + (let ([fallback (if (null? default) #f (car default))]) + (if (hash-table? obj) + (hash-ref obj key fallback) + fallback))) + + (def (jref who obj key) + (unless (hash-table? obj) + (error who "expected JSON object while reading" key)) + (let ([value (hash-ref obj key *missing*)]) + (when (eq? value *missing*) + (error who "missing JSON field" key)) + value)) + + (def (json-true? value) + (cond + [(eq? value #t) #t] + [(number? value) (not (= value 0))] + [(string? value) + (not (or (string=? value "") + (string=? value "0") + (string-ci=? value "false")))] + [else #f])) + + (def (proton-key-active? key) + (json-true? (jmaybe key "Active" 1))) + + (def (proton-key-primary? key) + (json-true? (jmaybe key "Primary" 0))) + + (def (proton-object-keys obj) + (let ([keys (jmaybe obj "Keys" '())]) + (if (list? keys) keys '()))) + + (def (find-first pred xs) + (cond + [(null? xs) #f] + [(pred (car xs)) (car xs)] + [else (find-first pred (cdr xs))])) + + (def (proton-primary-key user) + (let* ([keys (proton-object-keys user)] + [active (let loop ([xs keys] [acc '()]) + (cond + [(null? xs) (reverse acc)] + [(proton-key-active? (car xs)) + (loop (cdr xs) (cons (car xs) acc))] + [else (loop (cdr xs) acc)]))] + [primary (find-first proton-key-primary? active)]) + (or primary + (and (pair? active) (car active)) + (error 'proton-primary-key "no active Proton user key")))) + + (def (list->bytevector xs) + (let* ([n (length xs)] + [bv (make-bytevector n 0)]) + (let loop ([i 0] [xs xs]) + (unless (null? xs) + (bytevector-u8-set! bv i (car xs)) + (loop (+ i 1) (cdr xs)))) + bv)) + + (def (normalize-key-salt value) + (cond + [(string? value) value] + [(list? value) (u8vector->base64-string (list->bytevector value))] + [else (error 'proton-key-salt "unsupported Proton KeySalt value")])) + + (def (proton-key-salt salts key-id) + (let loop ([xs salts]) + (cond + [(null? xs) + (error 'proton-key-salt "no salt found for key" key-id)] + [(and (hash-table? (car xs)) + (equal? (jmaybe (car xs) "ID") key-id)) + (normalize-key-salt (jref 'proton-key-salt (car xs) "KeySalt"))] + [else (loop (cdr xs))]))) + + (def (proton-salted-key-pass key-pass user salts) + (let* ([primary (proton-primary-key user)] + [key-id (jref 'proton-salted-key-pass primary "ID")] + [salt (proton-key-salt salts key-id)]) + (proton-mailbox-password key-pass salt))) + + (def (active-keys obj) + (let loop ([xs (proton-object-keys obj)] [acc '()]) + (cond + [(null? xs) (reverse acc)] + [(proton-key-active? (car xs)) + (loop (cdr xs) (cons (car xs) acc))] + [else (loop (cdr xs) acc)]))) + + (def (key-private-armor key) + (let ([armor (jmaybe key "PrivateKey" "")]) + (and (string? armor) + (> (string-length armor) 0) + armor))) + + (def (key-token key) + (let ([token (jmaybe key "Token" "")]) + (and (string? token) + (> (string-length token) 0) + token))) + + (def (key-signature key) + (let ([sig (jmaybe key "Signature" "")]) + (and (string? sig) + (> (string-length sig) 0) + sig))) + + (def (key-id-string key) + (let ([id (jmaybe key "ID" "")]) + (if (string? id) id ""))) + + (def (address-id-string address) + (let ([id (jmaybe address "ID" "")]) + (if (string? id) id ""))) + + (def (order-addresses addresses wanted-id) + (if (not (and wanted-id (string? wanted-id) (> (string-length wanted-id) 0))) + addresses + (let loop ([xs addresses] [matches '()] [rest '()]) + (cond + [(null? xs) (append (reverse matches) (reverse rest))] + [(string=? (address-id-string (car xs)) wanted-id) + (loop (cdr xs) (cons (car xs) matches) rest)] + [else + (loop (cdr xs) matches (cons (car xs) rest))])))) + + (def (try-token-passphrase user-keys salted-pass-bv token signature) + (let loop ([xs user-keys]) + (cond + [(null? xs) #f] + [else + (let ([armor (key-private-armor (car xs))]) + (or (and armor + (guard (e [#t #f]) + (proton-crypto-token-passphrase armor salted-pass-bv token signature))) + (loop (cdr xs))))]))) + + (def (crypto-append-map f xs) + (let loop ([xs xs] [acc '()]) + (if (null? xs) + (reverse acc) + (loop (cdr xs) (append (reverse (f (car xs))) acc))))) + + (def (candidate key pass-bv source) + (list key pass-bv source)) + + (def (candidate-key c) (car c)) + (def (candidate-pass c) (cadr c)) + (def (candidate-source c) (caddr c)) + + (def (key-candidates user-keys salted-pass-bv address) + (crypto-append-map + (lambda (key) + (let ([armor (key-private-armor key)]) + (cond + [(not armor) '()] + [(and (key-token key) (key-signature key)) + (let ([pass (try-token-passphrase user-keys + salted-pass-bv + (key-token key) + (key-signature key))]) + (if pass + (list (candidate key pass (string-append "address:" + (address-id-string address)))) + '()))] + [else + (list (candidate key salted-pass-bv + (string-append "address:" + (address-id-string address))))]))) + (active-keys address))) + + (def (user-key-candidates user salted-pass-bv) + (crypto-append-map + (lambda (key) + (if (key-private-armor key) + (list (candidate key salted-pass-bv "user")) + '())) + (active-keys user))) + + (def (decryption-candidates user addresses salted-pass message) + (let* ([salted-pass-bv (string->utf8 salted-pass)] + [user-keys (active-keys user)] + [ordered-addresses + (order-addresses addresses (jmaybe message "AddressID" ""))]) + (append (crypto-append-map + (lambda (address) + (key-candidates user-keys salted-pass-bv address)) + ordered-addresses) + (user-key-candidates user salted-pass-bv)))) + + (def (message-body-armor message) + (let ([body (jref 'proton-decrypt-message message "Body")]) + (unless (string? body) + (error 'proton-decrypt-message "message Body must be a string")) + body)) + + (def (try-decrypt-candidate body candidate) + (let* ([key (candidate-key candidate)] + [armor (key-private-armor key)]) + (and armor + (guard (e [#t #f]) + (proton-crypto-pgp-decrypt armor (candidate-pass candidate) body))))) + + (def (proton-decrypt-message user addresses salts key-pass message) + (let* ([salted-pass (proton-salted-key-pass key-pass user salts)] + [body (message-body-armor message)] + [candidates (decryption-candidates user addresses salted-pass message)]) + (let loop ([xs candidates]) + (cond + [(null? xs) + (error 'proton-decrypt-message + "failed to decrypt message with available user/address keys")] + [else + (let ([plaintext (try-decrypt-candidate body (car xs))]) + (if plaintext + (make-proton-decryption-result + plaintext + (key-id-string (candidate-key (car xs))) + (candidate-source (car xs))) + (loop (cdr xs))))])))) + + (def (maybe-string obj key) + (let ([value (jmaybe obj key "")]) + (if (string? value) value ""))) + + (def (decrypted-body-string plaintext-bv) + (guard (e [#t (error 'proton-render-decrypted-message + "decrypted message body is not valid UTF-8")]) + (utf8->string plaintext-bv))) + + (def (message-raw-mime message plaintext-bv) + (let* ([body (decrypted-body-string plaintext-bv)] + [header (maybe-string message "Header")] + [mime-type (maybe-string message "MIMEType")]) + (cond + [(> (string-length header) 0) + (string-append header "\r\n\r\n" body)] + [(> (string-length mime-type) 0) + (string-append "Content-Type: " mime-type "\r\n\r\n" body)] + [else + (string-append "Content-Type: text/plain\r\n\r\n" body)]))) + + (def (proton-render-decrypted-message message plaintext-bv) + (let* ([raw (message-raw-mime message plaintext-bv)] + [parsed (mail-parse-message raw)] + [body (mail-best-text-body parsed)]) + (if (and (string? body) (> (string-length body) 0)) + body + (decrypted-body-string plaintext-bv)))) + + ) --- a/test/test-all.ss +++ b/test/test-all.ss @@ -30,6 +30,7 @@ (import (proton-bridge api auth)) (import (proton-bridge api mail)) (import (proton-bridge api session)) +(import (proton-bridge crypto)) (import (proton-bridge fido2)) (import (proton-bridge srp)) (import (only (yubikey fido2) make-fido2-assertion)) @@ -190,6 +191,9 @@ (string=? (proton-auth-access-token sample-auth-after-srp) "access-1") (string=? (proton-auth-refresh-token sample-auth-after-srp) "refresh-1"))) +(check "auth defaults to one-password mode" + (= (proton-auth-password-mode sample-auth-after-srp) 1)) + (check "auth detects FIDO2 requirement" (and (proton-auth-fido2-required? sample-auth-after-srp) (not (proton-auth-totp-required? sample-auth-after-srp)))) @@ -202,6 +206,38 @@ (string=? (proton-session-access-token session) "access-1") (string=? (proton-session-refresh-token session) "refresh-1")))) +(define sample-primary-key + (let ([obj (string->json-object "{}")]) + (hashtable-set! obj "ID" "key-1") + (hashtable-set! obj "Primary" 1) + (hashtable-set! obj "Active" 1) + (hashtable-set! obj "PrivateKey" "-----BEGIN PGP PRIVATE KEY BLOCK-----") + obj)) + +(define sample-user + (let ([obj (string->json-object "{}")]) + (hashtable-set! obj "Keys" (list sample-primary-key)) + obj)) + +(define sample-salt + (let ([obj (string->json-object "{}")]) + (hashtable-set! obj "ID" "key-1") + (hashtable-set! obj "KeySalt" "imK9IHsRcA2Zsv+yROZgbw==") + obj)) + +(check "crypto selects active primary Proton key" + (let ([key (proton-primary-key sample-user)]) + (and (proton-key-active? key) + (proton-key-primary? key) + (string=? (hashtable-ref key "ID" #f) "key-1")))) + +(check "crypto derives salted key pass from user key salt" + (string=? (proton-salted-key-pass + "password" + sample-user + (list sample-salt)) + "Q.Gd9rSsqE0xQ8Qcf0Q9ckInb4hIzOu")) + (define sample-folder (let ([obj (string->json-object "{}")]) (hashtable-set! obj "ID" "folder-1")