Add Proton FIDO2 auth payload probe

ober

7eac0883251c4fb14fd4b28d51cda9a71f4ac40e

diff --git a/README.md b/README.md
index e3f9e32..f921e34 100644
--- a/README.md
+++ b/README.md
@@ -77,3 +77,13 @@ single-user Unix socket, not a reusable IMAP password.
 make run ARGS='--help'
 make test
 ```
+
+Current `login` support is the FIDO2/Auth2FA payload probe:
+
+```sh
+make run ARGS='login --auth-options auth-options.json'
+```
+
+`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.
diff --git a/plan.md b/plan.md
index e516cea..edffbb2 100644
--- a/plan.md
+++ b/plan.md
@@ -221,10 +221,14 @@ Done:
 
 ### M1: YubiKey FIDO2 Assertion Prototype
 
-Deliverables:
+Done:
 
 - `jerboa-yubikey` API for FIDO2 assertion.
+- Proton-side WebAuthn client-data and Auth2FA payload construction.
 - Fixture test using static rpID/challenge/credential ID shape.
+
+Remaining:
+
 - Manual test against a real YubiKey, without Proton.
 
 Exit criteria:
diff --git a/proton-bridge/cli.ss b/proton-bridge/cli.ss
index b11aaa9..90c2cc5 100644
--- a/proton-bridge/cli.ss
+++ b/proton-bridge/cli.ss
@@ -13,7 +13,10 @@
                   iota 1+ 1-
                   partition
                   make-date make-time)
-          (proton-bridge security))
+          (only (std text json) string->json-object)
+          (proton-bridge security)
+          (proton-bridge fido2)
+          (only (yubikey fido2) fido2-assertion-credential-id))
 
   (define version "0.0.0-rewrite-plan")
 
@@ -23,7 +26,7 @@
       "\n"
       "commands:\n"
       "  status       Show rewrite/security status\n"
-      "  login        Native Proton login with YubiKey gate (planned)\n"
+      "  login        Native Proton login probe / FIDO2 payload generation\n"
       "  folders      List Proton folders (planned)\n"
       "  list         List messages (planned)\n"
       "  show         Fetch/decrypt/show one message (planned)\n"
@@ -58,8 +61,8 @@
             ": "
             (if (cdr item) "yes" "no"))))
       (security-summary))
-    (println "native Proton auth: planned")
-    (println "FIDO2/WebAuthn via jerboa-yubikey: planned")
+    (println "native Proton auth: SRP phase planned")
+    (println "FIDO2/WebAuthn via jerboa-yubikey: payload path available")
     (println "password-authenticated local IMAP: intentionally disabled"))
 
   (define (planned command)
@@ -68,6 +71,64 @@
            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))))
+
+  (define (opt opts k)
+    (let ([p (assoc k opts)])
+      (and p (cdr p))))
+
+  (define (split-opts args known-flags)
+    (let loop ([xs args] [opts '()] [pos '()])
+      (cond
+        [(null? xs) (cons (reverse opts) (reverse pos))]
+        [(and (string? (car xs))
+              (> (string-length (car xs)) 1)
+              (char=? (string-ref (car xs) 0) #\-))
+         (let ([info (assoc (car xs) known-flags)])
+           (cond
+             [(not info) (die 2 (string-append "unknown option: " (car xs)))]
+             [(cdr info)
+              (if (pair? (cdr xs))
+                (loop (cddr xs) (cons (cons (car xs) (cadr xs)) opts) pos)
+                (die 2 (string-append "option requires a value: " (car xs))))]
+             [else
+              (loop (cdr xs) (cons (cons (car xs) "true") opts) pos)]))]
+        [else (loop (cdr xs) opts (cons (car xs) pos))])))
+
+  (define (read-secret prompt)
+    (display prompt (current-error-port))
+    (system "stty -echo")
+    (let ([line (get-line (current-input-port))])
+      (system "stty echo")
+      (newline (current-error-port))
+      (if (eof-object? line) "" line)))
+
+  (define (cmd-login args)
+    (let* ([parsed (split-opts args
+                    '(("--auth-options" . #t)
+                      ("--prompt-pin" . #f)))]
+           [opts (car parsed)]
+           [auth-options-file (opt opts "--auth-options")])
+      (unless auth-options-file
+        (die 2
+             "login SRP is not implemented yet; pass --auth-options FILE to generate a FIDO2 Auth2FA payload"))
+      (let* ([json (string->json-object (read-file-string auth-options-file))]
+             [pin (if (opt opts "--prompt-pin")
+                    (read-secret "FIDO2 PIN: ")
+                    "")])
+        (println "Touch your YubiKey when it blinks.")
+        (call-with-values
+          (lambda () (proton-fido2-assert json 'pin: pin))
+          (lambda (auth-data assertion payload-json)
+            (println (string-append "rpId: " (proton-fido2-auth-data-rp-id auth-data)))
+            (println (string-append "credential bytes: "
+                                    (number->string
+                                      (bytevector-length
+                                        (fido2-assertion-credential-id assertion)))))
+            (println payload-json))))))
+
   (define (run-cli raw-args)
     (let ([args (strip-script-separator raw-args)])
       (cond
@@ -78,7 +139,7 @@
          (display usage-string)]
         [(string=? (car args) "version") (println version)]
         [(string=? (car args) "status") (print-status)]
-        [(string=? (car args) "login") (planned "login")]
+        [(string=? (car args) "login") (cmd-login (cdr args))]
         [(string=? (car args) "folders") (planned "folders")]
         [(string=? (car args) "list") (planned "list")]
         [(string=? (car args) "show") (planned "show")]
diff --git a/proton-bridge/fido2.ss b/proton-bridge/fido2.ss
new file mode 100644
index 0000000..4b0575b
--- /dev/null
+++ b/proton-bridge/fido2.ss
@@ -0,0 +1,196 @@
+#!chezscheme
+;;; (proton-bridge fido2) - Proton WebAuthn/FIDO2 auth payload helpers.
+
+(library (proton-bridge fido2)
+  (export
+    proton-fido2-auth-data?
+    make-proton-fido2-auth-data
+    proton-fido2-auth-data-rp-id
+    proton-fido2-auth-data-client-data-json
+    proton-fido2-auth-data-credential-ids
+    proton-fido2-auth-data-authentication-options
+    proton-fido2-authentication-options
+    proton-fido2-extract-auth-data
+    proton-fido2-auth2fa-payload
+    proton-fido2-auth2fa-json
+    proton-fido2-assert)
+
+  (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)
+          (yubikey fido2))
+
+  (defstruct proton-fido2-auth-data
+    (rp-id
+     client-data-json
+     credential-ids
+     authentication-options))
+
+  (def (jref who obj key)
+    (unless (hash-table? obj)
+      (error who "expected JSON object while reading" key))
+    (let ([value (hash-ref obj key #f)])
+      (unless value
+        (error who "missing JSON field" key))
+      value))
+
+  (def (jmaybe obj key)
+    (and (hash-table? obj) (hash-ref obj key #f)))
+
+  (def (u8-list->bv who xs)
+    (unless (list? xs)
+      (error who "expected JSON byte array" xs))
+    (let* ([n (length xs)]
+           [out (make-bytevector n 0)])
+      (let loop ([rest xs] [i 0])
+        (cond
+          [(null? rest) out]
+          [else
+           (let ([x (car rest)])
+             (unless (and (integer? x) (>= x 0) (<= x 255))
+               (error who "byte array value out of range" x))
+             (bytevector-u8-set! out i x)
+             (loop (cdr rest) (+ i 1)))]))))
+
+  (def (bv->u8-list bv)
+    (let loop ([i 0] [acc '()])
+      (if (= i (bytevector-length bv))
+        (reverse acc)
+        (loop (+ i 1) (cons (bytevector-u8-ref bv i) acc)))))
+
+  (def (json-object . fields)
+    (let ([ht (make-hash-table)])
+      (let loop ([xs fields])
+        (unless (null? xs)
+          (hash-put! ht (car xs) (cadr xs))
+          (loop (cddr xs))))
+      ht))
+
+  (def (client-data-json rp-id challenge-bv)
+    (string->utf8
+      (json-object->string
+        (json-object
+          "type" "webauthn.get"
+          "challenge" (u8vector->base64-string challenge-bv #t #f)
+          "origin" (string-append "https://" rp-id)))))
+
+  ;; Accept either:
+  ;;   - the raw AuthenticationOptions object with "publicKey"
+  ;;   - an object with "AuthenticationOptions"
+  ;;   - the full auth object containing "2FA" -> "FIDO2" -> "AuthenticationOptions"
+  (def (proton-fido2-authentication-options obj)
+    (cond
+      [(jmaybe obj "publicKey") obj]
+      [(jmaybe obj "AuthenticationOptions") (jref 'proton-fido2-authentication-options obj "AuthenticationOptions")]
+      [(jmaybe obj "2FA")
+       (jref 'proton-fido2-authentication-options
+             (jref 'proton-fido2-authentication-options
+                   (jref 'proton-fido2-authentication-options obj "2FA")
+                   "FIDO2")
+             "AuthenticationOptions")]
+      [else
+       (error 'proton-fido2-authentication-options
+              "could not locate FIDO2 AuthenticationOptions")]))
+
+  (def (credential-id-from-json cred)
+    (and (hash-table? cred)
+         (let ([id (hash-ref cred "id" #f)])
+           (and id (u8-list->bv 'proton-fido2-extract-auth-data id)))))
+
+  (def (credential-ids-from-json allow-credentials)
+    (unless (list? allow-credentials)
+      (error 'proton-fido2-extract-auth-data "allowCredentials must be a JSON array"))
+    (let loop ([xs allow-credentials] [acc '()])
+      (cond
+        [(null? xs)
+         (let ([ids (reverse acc)])
+           (when (null? ids)
+             (error 'proton-fido2-extract-auth-data "no valid credential IDs found"))
+           ids)]
+        [else
+         (let ([id (credential-id-from-json (car xs))])
+           (loop (cdr xs) (if id (cons id acc) acc)))])))
+
+  (def (proton-fido2-extract-auth-data authentication-options)
+    (let* ([options (proton-fido2-authentication-options authentication-options)]
+           [public-key (jref 'proton-fido2-extract-auth-data options "publicKey")]
+           [rp-id (jref 'proton-fido2-extract-auth-data public-key "rpId")]
+           [challenge (u8-list->bv 'proton-fido2-extract-auth-data
+                                   (jref 'proton-fido2-extract-auth-data public-key "challenge"))]
+           [credential-ids
+            (credential-ids-from-json
+              (jref 'proton-fido2-extract-auth-data public-key "allowCredentials"))])
+      (unless (string? rp-id)
+        (error 'proton-fido2-extract-auth-data "rpId must be a string"))
+      (make-proton-fido2-auth-data
+        rp-id
+        (client-data-json rp-id challenge)
+        credential-ids
+        options)))
+
+  (def (proton-fido2-auth2fa-payload auth-data assertion)
+    (json-object
+      "FIDO2"
+      (json-object
+        "AuthenticationOptions"
+        (proton-fido2-auth-data-authentication-options auth-data)
+        "ClientData"
+        (u8vector->base64-string
+          (proton-fido2-auth-data-client-data-json auth-data))
+        "AuthenticatorData"
+        (u8vector->base64-string
+          (fido2-assertion-authenticator-data assertion))
+        "Signature"
+        (u8vector->base64-string
+          (fido2-assertion-signature assertion))
+        "CredentialID"
+        (bv->u8-list (fido2-assertion-credential-id assertion)))))
+
+  (def (proton-fido2-auth2fa-json auth-data assertion)
+    (json-object->string (proton-fido2-auth2fa-payload auth-data assertion)))
+
+  (def (getopt opts kw)
+    (let loop ([xs opts])
+      (cond
+        [(null? xs) #f]
+        [(null? (cdr xs)) #f]
+        [(eq? (car xs) kw) (cadr xs)]
+        [else (loop (cddr xs))])))
+
+  (def (try-assert-with-credentials auth-data ids pin last-error)
+    (cond
+      [(null? ids)
+       (if last-error
+         (raise last-error)
+         (error 'proton-fido2-assert "no credential IDs available"))]
+      [else
+       (guard (e [#t (try-assert-with-credentials auth-data (cdr ids) pin e)])
+         (yubikey-fido2-assert
+           (proton-fido2-auth-data-rp-id auth-data)
+           (proton-fido2-auth-data-client-data-json auth-data)
+           (car ids)
+           'pin: pin))]))
+
+  ;; Returns (values auth-data assertion payload-json). This performs the
+  ;; hardware assertion but does not submit it to Proton.
+  (def (proton-fido2-assert authentication-options . opts)
+    (let* ([auth-data (proton-fido2-extract-auth-data authentication-options)]
+           [pin (or (getopt opts 'pin:) "")]
+           [assertion
+            (try-assert-with-credentials
+              auth-data
+              (proton-fido2-auth-data-credential-ids auth-data)
+              pin
+              #f)])
+      (values auth-data assertion (proton-fido2-auth2fa-json auth-data assertion))))
+
+  )
diff --git a/test/test-all.ss b/test/test-all.ss
index ab3b12d..44ca8f8 100644
--- a/test/test-all.ss
+++ b/test/test-all.ss
@@ -26,6 +26,10 @@
 
 (import (proton-bridge cli))
 (import (proton-bridge security))
+(import (proton-bridge fido2))
+(import (only (yubikey fido2) make-fido2-assertion))
+(import (only (std text json) string->json-object))
+(import (only (std text base64) base64-string->u8vector))
 
 (define failures 0)
 
@@ -65,6 +69,38 @@
 (check "default policy requires YubiKey"
        (policy-requires-yubikey? (default-security-policy)))
 
+(define sample-auth-json
+  "{\"publicKey\":{\"rpId\":\"proton.me\",\"challenge\":[1,2,3,4],\"allowCredentials\":[{\"type\":\"public-key\",\"id\":[9,8,7]}]}}")
+
+(check "fido2 extracts rpId"
+       (let* ([auth-data (proton-fido2-extract-auth-data
+                           (string->json-object sample-auth-json))])
+         (string=? (proton-fido2-auth-data-rp-id auth-data) "proton.me")))
+
+(check "fido2 client data carries base64url challenge"
+       (let* ([auth-data (proton-fido2-extract-auth-data
+                           (string->json-object sample-auth-json))]
+              [client-data (string->json-object
+                             (utf8->string
+                               (proton-fido2-auth-data-client-data-json auth-data)))])
+         (and (string=? (hashtable-ref client-data "type" #f) "webauthn.get")
+              (string=? (hashtable-ref client-data "origin" #f) "https://proton.me")
+              (string=? (hashtable-ref client-data "challenge" #f) "AQIDBA"))))
+
+(check "fido2 builds Auth2FA payload"
+       (let* ([auth-data (proton-fido2-extract-auth-data
+                           (string->json-object sample-auth-json))]
+              [assertion (make-fido2-assertion #vu8(9 8 7) #vu8(1 1 1) #vu8(2 2 2))]
+              [payload (string->json-object
+                         (proton-fido2-auth2fa-json auth-data assertion))]
+              [fido (hashtable-ref payload "FIDO2" #f)])
+         (and fido
+              (equal? (hashtable-ref fido "CredentialID" #f) '(9 8 7))
+              (equal? (base64-string->u8vector (hashtable-ref fido "AuthenticatorData" #f))
+                      #vu8(1 1 1))
+              (equal? (base64-string->u8vector (hashtable-ref fido "Signature" #f))
+                      #vu8(2 2 2)))))
+
 (if (= failures 0)
     (begin
       (fprintf (current-error-port) "~%All tests passed.~%")