Encrypted bookmarks unlocked by a YubiKey (PIV slot 9D)
ober
c41f8a42380669d975a0923c4893b33795de409d
--- a/.gitignore +++ b/.gitignore @@ -17,3 +17,7 @@ gui-snapshots.tar.gz # macOS .DS_Store + +# local dev: symlink to the Rust crypto lib so `jerbuild exec` (interpreter +# tests) can load it; the built binary registers these symbols statically. +lib/libjerboa_native.* --- a/Makefile +++ b/Makefile @@ -8,7 +8,7 @@ $(error jerbuild not found on PATH (or '$(JERBUILD) --jerboa-home' failed). Inst endif JEXEC := $(JERBUILD) exec --libdirs $(CURDIR)/scheme:$(JH)/lib -.PHONY: all build binary run test test-keymap test-minibuffer test-commands test-keys test-nav test-hint test-pass test-polish test-adblock test-gui test-buffers repl clean help +.PHONY: all build binary run test test-keymap test-minibuffer test-commands test-keys test-nav test-hint test-pass test-polish test-securestore test-adblock test-gui test-buffers repl clean help .DEFAULT_GOAL := help all: binary @@ -23,10 +23,17 @@ build: binary run: binary ./jerboa-browser $(ARGS) -# Run the (browser) test suite in the interpreter (no binary needed). -test: +# Run the (browser) test suite in the interpreter (no binary needed). Depends on +# the pure secure-store unit tests so they run as part of `make test`. +test: test-securestore $(JEXEC) scheme/browser-test.ss +# Stage 8 secure-store unit tests: bookmark (de)serialize, AES-256-GCM seal/open, +# RSA-OAEP wrap + simulated card unwrap, tamper detection, masked-DK zeroing. +# Pure — no Qt, no YubiKey; needs ./lib/libjerboa_native.* for the Rust crypto. +test-securestore: + $(JEXEC) scheme/browser-securestore-test.ss + # Pure-Scheme unit tests for the keymap engine (no Qt, no display needed). test-keymap: $(JEXEC) scheme/browser-keymap-test.ss --- a/README.md +++ b/README.md @@ -41,6 +41,7 @@ hint-mode. `C-h b` opens a buffer listing every binding. | `f` / `M-g` (or `; f`) | follow hint (this / new buffer) | hint-mode | | `C-c p s` / `C-c p f` / `C-c p k` | save / fill / forget login (RAM only) | passwords | | `C-x r m` / `C-x r b` | bookmark current / open bookmark | bookmarks | +| `C-c y i` / `C-c y u` / `C-c y l` | init / unlock / lock the YubiKey-encrypted store | YubiKey | | `C-c b` | toggle ad / tracker blocking | blocking | | `M-x` | run command by name (shows docs) | palette | | `C-h b` | describe all bindings | help | @@ -48,19 +49,43 @@ hint-mode. `C-h b` opens a buffer listing every binding. Passwords are held **in RAM only** — never written to env, config, or disk — XOR-masked in the heap with a per-session pad and zeroed immediately after each -use. Bookmarks are likewise in-RAM (opt-in encrypted persistence is a later item). +use; that is unchanged. **Bookmarks** can optionally persist **encrypted at rest, +unlocked by a YubiKey** (see below); the password vault stays RAM-only regardless. Ad / tracker blocking is **on by default**, powered by Brave's `adblock-rust` engine (vendored, linked into `libjerboa_browser`) and consulted on every network request. `C-c b` toggles it; the status line shows `block` while active and the echo area reports the running count of blocked requests. +## YubiKey-encrypted bookmarks + +Bookmarks (not passwords) can be saved **encrypted at rest** and unlocked with a +YubiKey's PIV applet — no `ykman`, `pcscd`, or other external tool needed. The +PIV transport is built-in PC/SC (Apple's PCSC.framework on macOS, pcsc-lite on +Linux); the crypto and the minimal YubiKey library are vendored +(`scheme/browser/{secure-store,yubikey-unlock}.ss`, `scheme/yubikey/`). + +- `C-c y i` — **init**: provisions PIV slot 9D if empty (generates an RSA-2048 + key — PIN-policy ALWAYS, touch CACHED — authenticating the default management + key), then writes the encrypted store. +- `C-c y u` — **unlock**: prompts for the PIV PIN (masked) + a touch, then loads + the bookmarks. +- `C-c y l` — **lock**: wipes the in-RAM data key and drops decrypted bookmarks. + +A random 256-bit data key encrypts the store with AES-256-GCM; that key is +RSA-OAEP-SHA256-wrapped to slot 9D's public key, so only this YubiKey (with its +PIN + a touch) can open the file. Saving needs no card (it wraps to the public +key); only unlocking talks to the card. Store: `$XDG_DATA_HOME/jerboa-browser/ +bookmarks.enc`. Needs a YubiKey 5 (firmware 5.3+); on Linux, install `pcsc-lite` +and run `pcscd`. + ## Build / test ```sh -make binary # the self-contained native ./jerboa-browser -make test # (browser) unit suite; also test-{keymap,…,polish,adblock} -make test-gui # offline Qt snapshot harness (offscreen, headless) +make binary # the self-contained native ./jerboa-browser +make test # (browser) suite + secure-store unit tests; also test-{keymap,…,polish} +make test-securestore # just the pure secure-store crypto/format unit tests +make test-gui # offline Qt snapshot harness (offscreen, headless) ``` The functional suites run offscreen (`QT_QPA_PLATFORM=offscreen`) and hermetic new file mode 100644 --- /dev/null +++ b/scheme/browser-securestore-test.ss @@ -0,0 +1,73 @@ +#!chezscheme +;;; scheme/browser-securestore-test — offline test for (browser secure-store). +;;; +;;; Pure: no GUI, no YubiKey. The PIV card's private RSA decrypt is simulated +;;; with c^d mod n against a pinned RSA-2048 test vector, so the whole +;;; wrap/seal/open/unwrap path is exercised with zero hardware. Run by +;;; `make test` (and `make test-securestore`); needs ./lib/libjerboa_native.* +;;; reachable for the Rust crypto backend (a symlink in lib/ provides it). + +(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 crypto bn) bn-expt-mod) + (only (std crypto native-rust) rust-random-bytes) + (browser secure-store)) + +;; pinned RSA-2048 test vector (test-only) +(define N (string->number "ab5bfeb0fdf6a2001acaf48c606cbdb9aeac5542873ef64ed83d70cb1fde16d1f6cf415925a2c2da9c72011c3805e0232e7ce63fece56150a6f17806c9601cb42e1545620cb42cc39b46102fefa9369ec9f469b85b4f63991e4c4a47cb7c6b84b0398cb0dca6aba41e24b8b38b2b0af6b2bc5852723b2d1aec7389ae8043ac7b9fe15f873bb5767ca1e24311344c87d82344c2c49a6c66566b89f5b2a97f0c7e83cde49a674b84124cda9e4b99e3a693a42194ed8949ee14cb211d3e711457b3568d2000edd613520441ec1deababc3794dac03ffad258747cc4eb33c38b1cf365555af922bc46987ba82c22193af392617055c11de01983e4ed83564edd9b51" 16)) +(define D (string->number "4f001c8d70a831cba68e86ebe8d0792f8fadf7a8b23d7ec49ec0c4ad80c59cf3b3bb9d3f0230e5706fcbc7634118c45ab3e5f528e78860b3142422d7ce233758821e605c71cae7104f17a002d994c38fb53faf35c532f691f2fbed0ae86f360a784c2fe6a1f35d124eab5353c3075708a1225ffdb2984195360996221314200224fc6bba92fdca7893f4327dcaae3875813cbc77b7b101932a0769de2ddd4d669785452c313c4d8d4b48e67074a2f99451ece14b9eb091914fdffa21cd7060ed9a9a8083cb8283a9ebc034d8b00d40e6e2bd59e995351f46d991b2063e6c853c99681b3119c3983ce8dc64286a22df515ab502c0e91899eeb0466b0041d3aa39" 16)) + +(define (i2osp x k) + (let ([out (make-bytevector k 0)]) + (let loop ([i (- k 1)] [v x]) + (if (< i 0) out (begin (bytevector-u8-set! out i (mod v 256)) (loop (- i 1) (div v 256))))))) +(define (os2ip b) (let loop ([i 0] [a 0]) (if (= i (bytevector-length b)) a (loop (+ i 1) (+ (* a 256) (bytevector-u8-ref b i)))))) +(define (bvcopy b) (let ([o (make-bytevector (bytevector-length b))]) (bytevector-copy! b 0 o 0 (bytevector-length b)) o)) +(define (card-decrypt wrapped) (i2osp (bn-expt-mod (os2ip wrapped) D N) 256)) ; simulate PIV + +(define modulus (i2osp N 256)) +(define exponent (u8-list->bytevector '(1 0 1))) + +(define pass 0) (define fail 0) +(define (chk name e a) (if (equal? e a) (begin (set! pass (+ pass 1)) (printf " ok ~a\n" name)) + (begin (set! fail (+ fail 1)) (printf " FAIL ~a\n exp ~s\n got ~s\n" name e a)))) + +(printf "\n=== secure-store (offline) ===\n") + +;; serialize round-trip incl. empty title + utf8 +(let ([pairs '(("https://a.com" . "Site A") ("https://b.org/x" . "") ("https://c.io" . "Çödé"))]) + (chk "pairs round-trip" pairs (deserialize-pairs (serialize-pairs pairs)))) + +;; full wrap -> simulated card decrypt -> unwrap -> seal -> open +(let* ([dk (rust-random-bytes 32)] + [wrapped (oaep-wrap modulus exponent dk)] + [keyid (keyid-of modulus exponent)] + [dk2 (oaep-unwrap-decode (card-decrypt wrapped))]) + (chk "DK survives wrap/unwrap" dk dk2) + (chk "wrapped is 256 bytes" 256 (bytevector-length wrapped)) + (let* ([payload (serialize-pairs '(("https://x" . "X")))] + [file (store-seal wrapped keyid dk2 payload)]) + (chk "magic ok" #t (store-magic-ok? file)) + (chk "open recovers payload" payload (store-open-with-dk dk2 file)) + (let-values ([(kid wr) (store-header-fields file)]) + (chk "header keyid" keyid kid) + (chk "header wrapped" wrapped wr)) + ;; tamper anywhere fails the GCM tag + (let ([f (bvcopy file)] [last (- (bytevector-length file) 1)]) + (bytevector-u8-set! f last (fxxor (bytevector-u8-ref f last) 1)) + (chk "tamper rejected" #t (guard (e (#t #t)) (store-open-with-dk dk2 f) #f))))) + +;; keyid stable + masked DK session zeroizes +(chk "keyid stable" (keyid-of modulus exponent) (keyid-of modulus exponent)) +(let* ([dk (rust-random-bytes 32)] [orig (bvcopy dk)] + [vs (vsession-create dk (make-bytevector 256 0) (make-bytevector 16 7))]) + (chk "vsession yields DK" orig (vsession-with-dk vs (lambda (k) (bvcopy k)))) + (chk "vsession keyid" (make-bytevector 16 7) (vsession-keyid vs)) + (vsession-wipe! vs) + (chk "vsession wiped to zero" (make-bytevector 32 0) (vsession-with-dk vs (lambda (k) (bvcopy k))))) + +(printf "\n ~a passed, ~a failed\n" pass fail) +(exit (if (= fail 0) 0 1)) --- a/scheme/browser/commands.ss +++ b/scheme/browser/commands.ss @@ -17,7 +17,7 @@ (export make-browser-app app? app-session app-keymap app-dispatcher app-minibuffer app-echo app-should-quit? - app-hints app-hint-buf app-vault app-bookmarks + app-hints app-hint-buf app-vault app-bookmarks app-store app-store-path app-feed-token! app-type! app-render! app-pump-keys! app-run-loop! emacs-keymap buffer-label @@ -40,7 +40,9 @@ (browser keymap) (browser minibuffer) (browser passwords) - (browser bookmarks)) + (browser bookmarks) + (browser secure-store) + (browser yubikey-unlock)) ;; --- string helpers ----------------------------------------------------- (def (substr? hay needle) @@ -84,16 +86,84 @@ ;; hint-new : #t when a followed hint should open in a new buffer ;; vault : the in-RAM, memory-only credential store (browser passwords) ;; bookmarks : the in-RAM bookmark store (browser bookmarks) + ;; store : a vsession (masked data key) when the encrypted bookmark + ;; store is unlocked, else #f (locked) + ;; store-path : path to the on-disk encrypted bookmark store (defstruct app (session keymap dispatcher minibuffer prompt-action echo quit search - hints hint-buf hint-new vault bookmarks)) + hints hint-buf hint-new vault bookmarks store store-path)) (def (make-browser-app session) (let* ((km (emacs-keymap)) (d (make-key-dispatcher km))) - (make-app session km d #f #f "" #f #f #f "" #f (make-vault) (make-bookmarks)))) + (make-app session km d #f #f "" #f #f #f "" #f (make-vault) (make-bookmarks) + #f (default-store-path)))) (def (app-should-quit? app) (and (app-quit app) #t)) (def (app-window app) (session-window (app-session app))) + ;; --- encrypted bookmark store: paths, file I/O, (de)serialization ------- + ;; Bookmarks (unlike the RAM-only password vault) can persist, encrypted at + ;; rest under a YubiKey-wrapped key. The store lives in the XDG data dir. + (def (xdg-data-home) + (let ((x (getenv "XDG_DATA_HOME"))) + (if (and x (> (string-length x) 0)) x + (string-append (or (getenv "HOME") ".") "/.local/share")))) + (def (default-store-path) + (string-append (xdg-data-home) "/jerboa-browser/bookmarks.enc")) + + (def (mkdir-p dir) + (unless (or (string=? dir "") (string=? dir "/") (file-exists? dir)) + (mkdir-p (path-parent dir)) + (guard (e (#t #f)) (mkdir dir)))) + + (def (read-store-file path) + (and (file-exists? path) + (let ((p (open-file-input-port path))) + (dynamic-wind (lambda () #f) + (lambda () (let ((b (get-bytevector-all p))) (if (eof-object? b) #vu8() b))) + (lambda () (close-port p)))))) + + (def (write-store-file! path bv) + (mkdir-p (path-parent path)) + (let ((p (open-file-output-port path (file-options no-fail)))) + (dynamic-wind (lambda () #f) + (lambda () (put-bytevector p bv)) + (lambda () (close-port p))))) + + (def (exn->msg e) (if (message-condition? e) (condition-message e) "error")) + + ;; bookmark list <-> (url . title) pairs (newest-first order preserved) + (def (bookmarks->pairs app) + (map (lambda (b) (cons (bookmark-url b) (bookmark-title b))) + (bookmarks-list (app-bookmarks app)))) + (def (merge-pairs->bookmarks! app pairs) + (for-each (lambda (p) (bookmarks-add! (app-bookmarks app) (car p) (cdr p))) + (reverse pairs))) + + ;; Re-seal + write the bookmark list using the unlocked data key. No card is + ;; needed (wrapping used the public key; the DK is cached masked in RAM). + (def (persist-bookmarks! app) + (let ((vs (app-store app))) + (when vs + (let ((payload (serialize-pairs (bookmarks->pairs app)))) + (vsession-with-dk vs + (lambda (dk) + (write-store-file! (app-store-path app) + (store-seal (vsession-wrapped vs) (vsession-keyid vs) dk payload)))))))) + + ;; Finish an unlock once the PIN is entered: echo the touch hint, then block + ;; on the card to unwrap the data key and load the bookmarks. + (def (do-yubikey-unlock! app pin) + (app-echo-set! app "Touch your YubiKey…") + (app-render! app) + (guard (e (#t (app-echo-set! app (string-append "Unlock failed: " (exn->msg e))))) + (let ((file (read-store-file (app-store-path app)))) + (let-values (((keyid wrapped) (store-header-fields file))) + (let* ((dk (yk-unwrap-dk pin wrapped)) + (payload (store-open-with-dk dk file))) + (merge-pairs->bookmarks! app (deserialize-pairs payload)) + (app-store-set! app (vsession-create dk wrapped keyid)) + (app-echo-set! app "Bookmarks unlocked")))))) + ;; Active minor modes, nyxt-style, for the status line: the base keyscheme is ;; always on; hint-mode shows while hinting. (Shown as "[emacs]" / "[emacs hint]".) (def (app-modes-string app) @@ -587,6 +657,10 @@ ;; bookmarks (Stage 6) — emacs register/bookmark prefix C-x r {m,b} ("C-x r m" . bookmark-current) ("C-x r b" . set-url-from-bookmark) + ;; encrypted bookmark store (YubiKey/PIV) — C-c y {u,l,i} + ("C-c y u" . yubikey-unlock) + ("C-c y l" . yubikey-lock) + ("C-c y i" . yubikey-init) ;; help (Stage 6) — C-h b lists all key bindings (emacs parity) ("C-h b" . describe-bindings) ("C-x C-c" . quit) @@ -750,7 +824,10 @@ (app-echo-set! app "No URL to bookmark") (begin (bookmarks-add! (app-bookmarks app) url title) - (app-echo-set! app (string-append "Bookmarked " title))))))))) + (if (app-store app) + (begin (persist-bookmarks! app) + (app-echo-set! app (string-append "Bookmarked " title " (saved)"))) + (app-echo-set! app (string-append "Bookmarked " title)))))))))) (register-command! 'set-url-from-bookmark "Load a bookmark in the current buffer (fuzzy)." (lambda (app) @@ -764,6 +841,50 @@ (browser-load v (bookmark-url bm)) (app-echo-set! app (string-append "Loaded " (bookmark-url bm))))))))))) + ;; --- encrypted bookmark store (YubiKey/PIV, Stage 8) -------------------- + ;; Bookmarks persist encrypted at rest; a key on PIV slot 9D unwraps the file + ;; key (PIN + touch). The password vault is unaffected — it stays RAM-only. + (register-command! 'yubikey-init + "Create the YubiKey-encrypted bookmark store (provisions PIV slot 9D if empty)." + (lambda (app) + (cond + ((app-store app) (app-echo-set! app "Store already unlocked")) + ((not (yk-reader-present?)) (app-echo-set! app "Insert your YubiKey first")) + (else + (guard (e (#t (app-echo-set! app (string-append "Init failed: " (exn->msg e))))) + (let-values (((modulus exponent keyid) (yk-ensure-store-key))) + (let* ((dk (store-new-dk)) + (wrapped (oaep-wrap modulus exponent dk)) + (payload (serialize-pairs (bookmarks->pairs app)))) + (write-store-file! (app-store-path app) (store-seal wrapped keyid dk payload)) + (app-store-set! app (vsession-create dk wrapped keyid)) ; consumes/wipes dk + (app-echo-set! app "Encrypted bookmark store created")))))))) + + (register-command! 'yubikey-unlock + "Unlock the encrypted bookmark store with your YubiKey (PIN + touch)." + (lambda (app) + (cond + ((app-store app) (app-echo-set! app "Already unlocked")) + ((not (read-store-file (app-store-path app))) + (app-echo-set! app "No store yet — create it with M-x yubikey-init")) + ((not (yk-reader-present?)) (app-echo-set! app "Insert your YubiKey to unlock")) + (else + (open-prompt! app "YubiKey PIN: " '() (lambda (x) x) + (lambda (app pin) (do-yubikey-unlock! app pin)) + #t))))) ; #t => masked input + + (register-command! 'yubikey-lock + "Lock the bookmark store: wipe the in-RAM key and drop decrypted bookmarks." + (lambda (app) + (let ((vs (app-store app))) + (if (not vs) + (app-echo-set! app "Already locked") + (begin + (vsession-wipe! vs) + (app-store-set! app #f) + (bookmarks-clear! (app-bookmarks app)) + (app-echo-set! app "Bookmarks locked")))))) + ;; --- help (Stage 6) ----------------------------------------------------- (register-command! 'describe-bindings "Show all key bindings in a new buffer." (lambda (app) @@ -792,6 +913,8 @@ (register-command! 'quit "Quit the browser." (lambda (app) + (let ((vs (app-store app))) (when vs (vsession-wipe! vs))) + (app-store-set! app #f) (app-quit-set! app #t) (guard (e (#t #f)) (browser-quit)))) new file mode 100644 --- /dev/null +++ b/scheme/browser/secure-store.ss @@ -0,0 +1,226 @@ +#!chezscheme +;;; (browser secure-store) — encrypted-at-rest store for bookmarks. +;;; +;;; This is the crypto + on-disk-format layer for the YubiKey-unlocked +;;; bookmark store. It is pure: no device access, no file I/O, no GUI. The +;;; orchestration (reading/writing files, prompting for the PIN, talking to +;;; the YubiKey) lives in (browser commands) and (browser yubikey-unlock). +;;; +;;; Threat model: the file is encrypted with a random 256-bit data key (DK) +;;; under AES-256-GCM. The DK is itself wrapped with RSA-OAEP-SHA256 to the +;;; public key of a PIV slot, so only that YubiKey (with its PIN, and a touch) +;;; can recover the DK and open the file. Wrapping needs only the public key +;;; (so saving never needs the card); unwrapping is the card's private decrypt. +;;; The password vault is unaffected — it stays RAM-only (see passwords.ss). +;;; +;;; File layout (all big-endian): +;;; MAGIC "JBMK" (4) | VERSION (1) | WRAP (1) | SLOT (1) | +;;; KEYID sha256(modulus||exponent)[0:16] (16) | WRAPPED_DK (256) | +;;; NONCE (12) | CIPHERTEXT(payload)+GCM-TAG +;;; AAD = the whole header through NONCE (binds version/slot/key-id/wrapped-DK +;;; to the ciphertext — tampering anywhere fails the GCM tag). +;;; +;;; Payload (plaintext) is a count-prefixed list of (url,title) UTF-8 pairs. + +(library (browser secure-store) + (export + ;; bookmark (de)serialization — list of (url . title) string pairs + serialize-pairs deserialize-pairs + ;; file seal/open (DK is a transient 32-byte bytevector) + store-seal store-open-with-dk store-header-fields store-magic-ok? + ;; RSA-OAEP key wrap/unwrap (pure; the card does the private decrypt) + oaep-wrap oaep-unwrap-decode keyid-of store-new-dk + ;; in-RAM data-key session (masked, like the password vault) + vsession-create vsession-with-dk vsession-wipe! + vsession-wrapped vsession-keyid vsession?) + + (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 crypto native-rust) + rust-aead-seal rust-aead-open rust-random-bytes rust-sha256) + (only (std crypto bn) bn-expt-mod) + (only (std security secret) wipe-bytevector!)) + + (def MAGIC (string->utf8 "JBMK")) + (def VERSION 1) + (def WRAP 1) ; 1 = PIV-RSA2048-OAEP-SHA256 + AES-256-GCM + (def SLOT #x9D) ; informational; the real slot is chosen at unlock + (def HLEN 32) ; SHA-256 / OAEP hash length + (def KBYTES 256) ; RSA-2048 modulus size in bytes + (def HDR-LEN 291) ; 4+1+1+1+16+256+12 + (def NONCE-LEN 12) + + ;; --- small byte helpers (self-contained) --- + (def (bvcat . bvs) + (let* ([tot (apply + (map bytevector-length bvs))] [out (make-bytevector tot 0)]) + (let loop ([bs bvs] [off 0]) + (if (null? bs) out + (let ([n (bytevector-length (car bs))]) + (bytevector-copy! (car bs) 0 out off n) + (loop (cdr bs) (+ off n))))))) + (def (sub bv s e) + (let ([out (make-bytevector (- e s))]) (bytevector-copy! bv s out 0 (- e s)) out)) + (def (bvcopy bv) (sub bv 0 (bytevector-length bv))) + (def (xor-into! dst src) + (let ([n (min (bytevector-length dst) (bytevector-length src))]) + (do ([i 0 (+ i 1)]) [(= i n) dst] + (bytevector-u8-set! dst i (bitwise-xor (bytevector-u8-ref dst i) + (bytevector-u8-ref src i)))))) + (def (u16->bv n) (bv (bitwise-and (bitwise-arithmetic-shift-right n 8) #xff) + (bitwise-and n #xff))) + (def (u32->bv n) (bv (bitwise-and (bitwise-arithmetic-shift-right n 24) #xff) + (bitwise-and (bitwise-arithmetic-shift-right n 16) #xff) + (bitwise-and (bitwise-arithmetic-shift-right n 8) #xff) + (bitwise-and n #xff))) + (def (bv . xs) (u8-list->bytevector xs)) + (def (u16-ref b o) (+ (* 256 (bytevector-u8-ref b o)) (bytevector-u8-ref b (+ o 1)))) + (def (u32-ref b o) (+ (* 16777216 (bytevector-u8-ref b o)) + (* 65536 (bytevector-u8-ref b (+ o 1))) + (* 256 (bytevector-u8-ref b (+ o 2))) + (bytevector-u8-ref b (+ o 3)))) + + ;; --- bookmark (de)serialization --- + ;; pairs :: list of (url-string . title-string) + (def (serialize-pairs pairs) + (apply bvcat (u32->bv (length pairs)) + (map (lambda (p) + (let ([u (string->utf8 (car p))] [t (string->utf8 (cdr p))]) + (bvcat (u16->bv (bytevector-length u)) u + (u16->bv (bytevector-length t)) t))) + pairs))) + + (def (deserialize-pairs b) + (let ([n (u32-ref b 0)]) + (let loop ([i 0] [off 4] [acc '()]) + (if (= i n) (reverse acc) + (let* ([ulen (u16-ref b off)] + [u (sub b (+ off 2) (+ off 2 ulen))] + [off2 (+ off 2 ulen)] + [tlen (u16-ref b off2)] + [t (sub b (+ off2 2) (+ off2 2 tlen))] + [off3 (+ off2 2 tlen)]) + (loop (+ i 1) off3 + (cons (cons (utf8->string u) (utf8->string t)) acc))))))) + + ;; --- RSA-OAEP (SHA-256, empty label) --- + ;; lHash is computed lazily: merely loading this module then needs no native + ;; crypto, so the interpreter test suite (which imports the command layer but + ;; never unlocks) loads fine without libjerboa_native on the path. The built + ;; binary registers the symbols statically, and a real unlock calls (lhash). + (def *lhash* #f) + (def (lhash) (or *lhash* (let ([h (rust-sha256 #vu8())]) (set! *lhash* h) h))) + (def (i2osp x k) + (let ([out (make-bytevector k 0)]) + (let loop ([i (- k 1)] [v x]) + (if (< i 0) out + (begin (bytevector-u8-set! out i (mod v 256)) (loop (- i 1) (div v 256))))))) + (def (os2ip b) + (let loop ([i 0] [acc 0]) + (if (= i (bytevector-length b)) acc + (loop (+ i 1) (+ (* acc 256) (bytevector-u8-ref b i)))))) + (def (mgf1 seed len) + (let loop ([c 0] [acc '()] [have 0]) + (if (>= have len) + (sub (apply bvcat (reverse acc)) 0 len) + (loop (+ c 1) (cons (rust-sha256 (bvcat seed (i2osp c 4))) acc) (+ have HLEN))))) + (def (oaep-encode msg seed) + (let* ([mlen (bytevector-length msg)] + [ps (make-bytevector (- KBYTES mlen (* 2 HLEN) 2) 0)] + [db (bvcat (lhash) ps (bv 1) msg)] + [dbmask (mgf1 seed (- KBYTES HLEN 1))] + [masked-db (xor-into! (bvcopy db) dbmask)] + [seedmask (mgf1 masked-db HLEN)] + [masked-seed (xor-into! (bvcopy seed) seedmask)]) + (bvcat (bv 0) masked-seed masked-db))) + (def (oaep-decode em) + (let* ([y (bytevector-u8-ref em 0)] + [masked-seed (sub em 1 (+ 1 HLEN))] + [masked-db (sub em (+ 1 HLEN) KBYTES)] + [seed (xor-into! (bvcopy masked-seed) (mgf1 masked-db HLEN))] + [db (xor-into! (bvcopy masked-db) (mgf1 seed (- KBYTES HLEN 1)))] + [lhash2 (sub db 0 HLEN)]) + (when (not (= y 0)) (error 'oaep-decode "OAEP: nonzero leading byte")) + (when (not (equal? lhash2 (lhash))) (error 'oaep-decode "OAEP: label-hash mismatch")) + (let loop ([i HLEN]) + (cond + [(>= i (bytevector-length db)) (error 'oaep-decode "OAEP: no 0x01 separator")] + [(= (bytevector-u8-ref db i) 1) (sub db (+ i 1) (bytevector-length db))] + [(= (bytevector-u8-ref db i) 0) (loop (+ i 1))] + [else (error 'oaep-decode "OAEP: bad padding byte")])))) + + ;; Wrap a 32-byte DK to an RSA public key (modulus/exponent big-endian bvs). + ;; Returns the 256-byte wrapped key. + (def (oaep-wrap modulus-bv exponent-bv dk) + (i2osp (bn-expt-mod (os2ip (oaep-encode dk (rust-random-bytes HLEN))) + (os2ip exponent-bv) (os2ip modulus-bv)) + KBYTES)) + ;; Decode the raw block the card returned from its private RSA decrypt → DK. + (def (oaep-unwrap-decode em) (oaep-decode em)) + + ;; 16-byte key identifier = sha256(modulus || exponent)[0:16]. + (def (keyid-of modulus-bv exponent-bv) + (sub (rust-sha256 (bvcat modulus-bv exponent-bv)) 0 16)) + + ;; Fresh 256-bit data key from the CSPRNG. + (def (store-new-dk) (rust-random-bytes 32)) + + ;; --- file seal / open --- + ;; wrapped: 256-byte wrapped DK; keyid: 16 bytes; dk: transient 32-byte key. + (def (store-seal wrapped keyid dk payload) + (let* ([nonce (rust-random-bytes NONCE-LEN)] + [header (bvcat MAGIC (bv VERSION WRAP SLOT) keyid wrapped nonce)] + [ct (rust-aead-seal dk nonce payload header)]) + (bvcat header ct))) + + (def (store-magic-ok? file) + (and (>= (bytevector-length file) HDR-LEN) + (equal? (sub file 0 4) MAGIC))) + + ;; Returns (values keyid wrapped) from a file's header (no DK needed). Lets + ;; the caller check the key-id and fetch the wrapped DK to hand to the card. + (def (store-header-fields file) + (when (not (store-magic-ok? file)) + (error 'store-header-fields "not a JBMK store (bad magic or too short)")) + (values (sub file 7 23) (sub file 23 279))) + + ;; Decrypt the payload given the recovered DK. Raises on tamper (GCM tag). + (def (store-open-with-dk dk file) + (when (not (store-magic-ok? file)) + (error 'store-open-with-dk "not a JBMK store")) + (let ([header (sub file 0 HDR-LEN)] + [nonce (sub file 279 291)] + [ct (sub file HDR-LEN (bytevector-length file))]) + (rust-aead-open dk nonce ct header))) + + ;; --- in-RAM data-key session (masked, mirrors passwords.ss) --- + ;; Holds the DK XOR-masked with a random pad, plus the (constant) wrapped DK + ;; and key-id so saves re-seal without touching the card. dk is consumed. + (defstruct %vsession (masked pad wrapped keyid)) + (def (vsession? x) (%vsession? x)) + (def (vsession-wrapped vs) (%vsession-wrapped vs)) + (def (vsession-keyid vs) (%vsession-keyid vs)) + (def (vsession-create dk wrapped keyid) + (let* ([pad (rust-random-bytes (bytevector-length dk))] + [masked (bvcopy dk)]) + (xor-into! masked pad) + (wipe-bytevector! dk) + (make-%vsession masked pad wrapped keyid))) + ;; Reconstitute the DK into a transient bytevector for `proc`, wiped after. + (def (vsession-with-dk vs proc) + (let ([dk (bvcopy (%vsession-masked vs))]) + (xor-into! dk (%vsession-pad vs)) + (dynamic-wind (lambda () #f) (lambda () (proc dk)) + (lambda () (wipe-bytevector! dk))))) + (def (vsession-wipe! vs) + (wipe-bytevector! (%vsession-masked vs)) + (wipe-bytevector! (%vsession-pad vs))) + + ) ; library (browser secure-store) new file mode 100644 --- /dev/null +++ b/scheme/browser/yubikey-unlock.ss @@ -0,0 +1,85 @@ +#!chezscheme +;;; (browser yubikey-unlock) — the device side of the encrypted bookmark store. +;;; +;;; Talks to the PIV applet (over PC/SC) to (a) read the slot-9D public key for +;;; wrapping a fresh data key, and (b) verify the PIN and unwrap the data key +;;; with the card's private RSA decrypt. The pure crypto/format lives in +;;; (browser secure-store); the GUI orchestration in (browser commands). +;;; +;;; All entry points raise on failure (no card, wrong PIN with retries, no key +;;; in the slot, touch timeout) — the caller catches and shows the message. + +(library (browser yubikey-unlock) + (export + yk-reader-present? ; → bool (never raises) + yk-store-pubkey ; → (values modulus exponent keyid) [card present] + yk-ensure-store-key ; like yk-store-pubkey, but provisions slot 9D if empty + yk-unwrap-dk ; (pin wrapped-256) → 32-byte DK [card+PIN+touch] + piv-key-mgmt-slot) + + (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?) + (yubikey transport connection) + (yubikey piv) + (browser secure-store)) + + (def piv-key-mgmt-slot PIV-SLOT-KEY-MGMT) ; #x9D — PIV "Key Management" slot + + ;; True if at least one YubiKey reader is attached. Never raises (a missing + ;; PC/SC backend or no reader just means "not present"). + (def (yk-reader-present?) + (guard (e (#t #f)) (pair? (yk-list-readers)))) + + ;; Read slot-9D's RSA public key and derive its key-id. Needs the card but no + ;; PIN (public key only) — used when creating/refreshing the store. + ;; (yk-with-connection collapses its thunk to a single value, so return a + ;; list from inside and spread it to values outside.) + (def (yk-store-pubkey) + (apply values + (yk-with-connection + (lambda (conn) + (let* ([md (yk-piv-metadata conn piv-key-mgmt-slot)] + [pk (piv-rsa-pubkey-from-metadata md)] + [modulus (piv-rsa-pubkey-modulus pk)] + [exponent (piv-rsa-pubkey-exponent pk)]) + (list modulus exponent (keyid-of modulus exponent))))))) + + ;; Like yk-store-pubkey, but if slot 9D is empty it generates an RSA-2048 key + ;; there first (authenticating the default AES-192 management key) — so the + ;; browser can provision with no external tool. Generation needs no PIN/touch + ;; (the management key has touch policy NEVER). Returns + ;; (values modulus exponent keyid). + (def (yk-ensure-store-key) + (apply values + (yk-with-connection + (lambda (conn) + (let* ([md (guard (e (#t #f)) (yk-piv-metadata conn piv-key-mgmt-slot))] + [pk (if md + (piv-rsa-pubkey-from-metadata md) + (begin + (yk-piv-authenticate-management-key conn PIV-DEFAULT-MGMT-KEY) + (yk-piv-generate-key conn piv-key-mgmt-slot + 'algorithm: PIV-ALG-RSA-2048 'pin-policy: 3 'touch-policy: 3)))] + [modulus (piv-rsa-pubkey-modulus pk)] + [exponent (piv-rsa-pubkey-exponent pk)]) + (list modulus exponent (keyid-of modulus exponent))))))) + + ;; Verify `pin` and unwrap `wrapped` (256-byte RSA-OAEP block) to the 32-byte + ;; data key. The PIN is verified immediately before the decrypt with no + ;; intervening SELECT (so pin-policy=ALWAYS works). May block until the user + ;; touches the key, per the slot's touch policy. + (def (yk-unwrap-dk pin wrapped) + (yk-with-connection + (lambda (conn) + (yk-piv-pin-verify conn pin) + (oaep-unwrap-decode (yk-piv-decrypt conn piv-key-mgmt-slot wrapped #f))))) + + ) ; library (browser yubikey-unlock) new file mode 100644 --- /dev/null +++ b/scheme/yubikey/VENDORED.md @@ -0,0 +1,10 @@ +# Vendored from ~/mine/jerboa-yubikey (git.sr.ht/~lisp/jerboa-yubikey) + +Minimal closure for PIV key-unwrap over PC/SC, used by (browser yubikey-unlock): + util, tlv, apdu, device, piv, transport/{connection,native,pcsc}. + +PIV runs over PC/SC (PCSC.framework on macOS, libpcsclite on Linux) via runtime +dlopen — no Rust/FFI symbols are linked. transport/native is included only so +connection.ss compiles; it degrades to PC/SC when libyubikey_native is absent. + +To refresh: re-copy these files from the jerboa-yubikey checkout. new file mode 100644 --- /dev/null +++ b/scheme/yubikey/aes.ss @@ -0,0 +1,147 @@ +#!chezscheme +;;; (yubikey aes) — minimal AES-128/192/256 block cipher (single-block ECB). +;;; +;;; Pure Scheme, no native dependency. Needed for PIV management-key +;;; authentication: YubiKey 5.7+ defaults the PIV management key to AES-192, and +;;; the admin mutual-auth (GENERAL AUTHENTICATE against slot 9B) encrypts/ +;;; decrypts one cipher block with it. The S-box is computed from the GF(2^8) +;;; inverse + affine map (no transcription), and the whole thing is checked +;;; against the FIPS-197 known-answer vectors in test/test-aes.ss. + +(library (yubikey aes) + (export aes-expand-key aes-encrypt-block aes-decrypt-block) + + (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?)) + + ;; --- GF(2^8) arithmetic (AES polynomial 0x11b) --- + (def (gmul a b) + (let loop ([a a] [b b] [p 0]) + (if (= b 0) + p + (let* ([p2 (if (odd? b) (bitwise-xor p a) p)] + [hi (>= a #x80)] + [a2 (bitwise-and (bitwise-arithmetic-shift-left a 1) #xff)]) + (loop (if hi (bitwise-xor a2 #x1b) a2) + (bitwise-arithmetic-shift-right b 1) + p2))))) + (def (gpow b e) + (let loop ([e e] [base b] [acc 1]) + (if (= e 0) acc + (loop (bitwise-arithmetic-shift-right e 1) + (gmul base base) + (if (odd? e) (gmul acc base) acc))))) + (def (xtime a) + (let ([s (bitwise-arithmetic-shift-left a 1)]) + (bitwise-and (if (>= a #x80) (bitwise-xor s #x1b) s) #xff))) + (def (rotl8 x n) + (bitwise-and (bitwise-ior (bitwise-arithmetic-shift-left x n) + (bitwise-arithmetic-shift-right x (- 8 n))) + #xff)) + + ;; --- S-box / inverse S-box, computed once --- + (def sbox + (let ([t (make-bytevector 256 0)]) + (do ([b 0 (+ b 1)]) [(= b 256) t] + (let* ([inv (if (= b 0) 0 (gpow b 254))] ; b^254 = b^-1 in GF(2^8) + [s (bitwise-and + (bitwise-xor inv (rotl8 inv 1) (rotl8 inv 2) + (rotl8 inv 3) (rotl8 inv 4) #x63) + #xff)]) + (bytevector-u8-set! t b s))))) + (def inv-sbox + (let ([t (make-bytevector 256 0)]) + (do ([b 0 (+ b 1)]) [(= b 256) t] + (bytevector-u8-set! t (bytevector-u8-ref sbox b) b)))) + (def (sb x) (bytevector-u8-ref sbox x)) + + ;; --- Key expansion (Nk = 4/6/8 → AES-128/192/256) --- + (def (aes-expand-key key) + (let* ([nk (quotient (bytevector-length key) 4)] + [nr (+ nk 6)] + [nwords (* 4 (+ nr 1))] + [rk (make-bytevector (* nwords 4) 0)]) + (bytevector-copy! key 0 rk 0 (bytevector-length key)) + (let loop ([i nk] [rcon 1]) + (if (= i nwords) + rk + (let* ([wp (* (- i 1) 4)] [wk (* (- i nk) 4)] [w (* i 4)] + [a0 (bytevector-u8-ref rk wp)] [a1 (bytevector-u8-ref rk (+ wp 1))] + [a2 (bytevector-u8-ref rk (+ wp 2))] [a3 (bytevector-u8-ref rk (+ wp 3))]) + (let-values ([(t0 t1 t2 t3 rcon2) + (cond + [(= (modulo i nk) 0) + (values (bitwise-xor (sb a1) rcon) (sb a2) (sb a3) (sb a0) + (xtime rcon))] + [(and (> nk 6) (= (modulo i nk) 4)) + (values (sb a0) (sb a1) (sb a2) (sb a3) rcon)] + [else (values a0 a1 a2 a3 rcon)])]) + (bytevector-u8-set! rk w (bitwise-xor (bytevector-u8-ref rk wk) t0)) + (bytevector-u8-set! rk (+ w 1) (bitwise-xor (bytevector-u8-ref rk (+ wk 1)) t1)) + (bytevector-u8-set! rk (+ w 2) (bitwise-xor (bytevector-u8-ref rk (+ wk 2)) t2)) + (bytevector-u8-set! rk (+ w 3) (bitwise-xor (bytevector-u8-ref rk (+ wk 3)) t3)) + (loop (+ i 1) rcon2))))))) + + ;; --- State transforms (state byte at row r, col c == s[4c+r]) --- + (def (copy16 b) (let ([o (make-bytevector 16 0)]) (bytevector-copy! b 0 o 0 16) o)) + (def (add-round-key! s rk round) + (let ([off (* round 16)]) + (do ([i 0 (+ i 1)]) [(= i 16)] + (bytevector-u8-set! s i (bitwise-xor (bytevector-u8-ref s i) + (bytevector-u8-ref rk (+ off i))))))) + (def (sub-bytes! s box) + (do ([i 0 (+ i 1)]) [(= i 16)] + (bytevector-u8-set! s i (bytevector-u8-ref box (bytevector-u8-ref s i))))) + (def (shift-rows! s dir) ; dir = +1 (encrypt, left) or -1 (decrypt, right) + (do ([r 1 (+ r 1)]) [(= r 4)] + (let ([row (vector (bytevector-u8-ref s r) (bytevector-u8-ref s (+ 4 r)) + (bytevector-u8-ref s (+ 8 r)) (bytevector-u8-ref s (+ 12 r)))]) + (do ([c 0 (+ c 1)]) [(= c 4)] + (bytevector-u8-set! s (+ (* 4 c) r) + (vector-ref row (modulo (+ c (* dir r)) 4))))))) + (def (mix-columns! s) + (do ([c 0 (+ c 1)]) [(= c 4)] + (let* ([i (* 4 c)] + [a0 (bytevector-u8-ref s i)] [a1 (bytevector-u8-ref s (+ i 1))] + [a2 (bytevector-u8-ref s (+ i 2))] [a3 (bytevector-u8-ref s (+ i 3))]) + (bytevector-u8-set! s i (bitwise-xor (gmul a0 2) (gmul a1 3) a2 a3)) + (bytevector-u8-set! s (+ i 1) (bitwise-xor a0 (gmul a1 2) (gmul a2 3) a3)) + (bytevector-u8-set! s (+ i 2) (bitwise-xor a0 a1 (gmul a2 2) (gmul a3 3))) + (bytevector-u8-set! s (+ i 3) (bitwise-xor (gmul a0 3) a1 a2 (gmul a3 2)))))) + (def (inv-mix-columns! s) + (do ([c 0 (+ c 1)]) [(= c 4)] + (let* ([i (* 4 c)] + [a0 (bytevector-u8-ref s i)] [a1 (bytevector-u8-ref s (+ i 1))] + [a2 (bytevector-u8-ref s (+ i 2))] [a3 (bytevector-u8-ref s (+ i 3))]) + (bytevector-u8-set! s i (bitwise-xor (gmul a0 14) (gmul a1 11) (gmul a2 13) (gmul a3 9))) + (bytevector-u8-set! s (+ i 1) (bitwise-xor (gmul a0 9) (gmul a1 14) (gmul a2 11) (gmul a3 13))) + (bytevector-u8-set! s (+ i 2) (bitwise-xor (gmul a0 13) (gmul a1 9) (gmul a2 14) (gmul a3 11))) + (bytevector-u8-set! s (+ i 3) (bitwise-xor (gmul a0 11) (gmul a1 13) (gmul a2 9) (gmul a3 14)))))) + + (def (nr-of rk) (- (quotient (bytevector-length rk) 16) 1)) + + (def (aes-encrypt-block rk block) + (let ([s (copy16 block)] [nr (nr-of rk)]) + (add-round-key! s rk 0) + (do ([round 1 (+ round 1)]) [(= round nr)] + (sub-bytes! s sbox) (shift-rows! s 1) (mix-columns! s) (add-round-key! s rk round)) + (sub-bytes! s sbox) (shift-rows! s 1) (add-round-key! s rk nr) + s)) + + (def (aes-decrypt-block rk block) + (let ([s (copy16 block)] [nr (nr-of rk)]) + (add-round-key! s rk nr) + (do ([round (- nr 1) (- round 1)]) [(= round 0)] + (shift-rows! s -1) (sub-bytes! s inv-sbox) (add-round-key! s rk round) (inv-mix-columns! s)) + (shift-rows! s -1) (sub-bytes! s inv-sbox) (add-round-key! s rk 0) + s)) + + ) ; library (yubikey aes) new file mode 100644 --- /dev/null +++ b/scheme/yubikey/apdu.ss @@ -0,0 +1,182 @@ +#!chezscheme +;;; (yubikey apdu) — ISO 7816-4 APDU encoding and response handling. +;;; +;;; An APDU sent to a YubiKey applet has the form +;;; +;;; CLA INS P1 P2 [Lc] [Data] [Le] +;;; +;;; with short / extended length forms per §5.1 of ISO 7816-4. YubiKey +;;; applets accept short form for ≤255-byte payloads and use response +;;; chaining (SW = 61xx → GET RESPONSE 00 C0 00 00 xx) for longer +;;; responses; the OATH applet specifies its own continuation INS +;;; (SEND REMAINING = 0xA5) for the same purpose. +;;; +;;; Status words are the trailing two bytes of a response. We split +;;; the (data, sw) pair so callers don't have to slice manually. + +(library (yubikey apdu) + (export + ;; Construction + apdu ;; full APDU bytevector + apdu-select ;; SELECT (INS 0xA4 P1=04 P2=00) by AID + apdu-get-response ;; ISO GET RESPONSE 00 C0 00 00 Le + apdu-send-remaining ;; OATH SEND REMAINING 00 A5 00 00 00 + + ;; Response handling + split-response ;; bv → (values data sw) + sw ;; (sw data sw-int) destructured tools + sw->string + sw-ok? + sw-more-data? ;; #t if SW = 61xx + sw-more-bytes ;; how many extra bytes (lower byte of 61xx) + + ;; Constants + INS-SELECT + INS-GET-RESPONSE + INS-SEND-REMAINING + SW-OK + SW-AUTH-REQUIRED + SW-WRONG-DATA + SW-WRONG-PARAMS + SW-NO-SPACE + SW-COMMAND-ABORTED + SW-COMMAND-NOT-ALLOWED + SW-INS-NOT-SUPPORTED + SW-CLA-NOT-SUPPORTED + SW-FILE-NOT-FOUND) + + (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?) + (yubikey util)) + + ;; --- Common INS values --- + + (def INS-SELECT #xA4) + (def INS-GET-RESPONSE #xC0) ;; ISO 7816 standard + (def INS-SEND-REMAINING #xA5) ;; OATH applet only + + ;; --- Status words --- + + (def SW-OK #x9000) + (def SW-AUTH-REQUIRED #x6982) + (def SW-WRONG-DATA #x6A80) + (def SW-WRONG-PARAMS #x6A86) + (def SW-NO-SPACE #x6A84) + (def SW-COMMAND-ABORTED #x6F00) + (def SW-COMMAND-NOT-ALLOWED #x6986) + (def SW-INS-NOT-SUPPORTED #x6D00) + (def SW-CLA-NOT-SUPPORTED #x6E00) + (def SW-FILE-NOT-FOUND #x6A82) + + (def (sw-ok? n) (= n SW-OK)) + (def (sw-more-data? n) (= (bitwise-arithmetic-shift-right n 8) #x61)) + (def (sw-more-bytes n) (bitwise-and n #xff)) + + (def (sw->string n) + (cond + [(= n SW-OK) "OK"] + [(sw-more-data? n) + (format "61 ~2,'0x — more data (~d bytes)" (sw-more-bytes n) (sw-more-bytes n))] + [(= n SW-AUTH-REQUIRED) "auth required (6982)"] + [(= n SW-WRONG-DATA) "wrong data (6A80)"] + [(= n SW-WRONG-PARAMS) "wrong parameters (6A86)"] + [(= n SW-NO-SPACE) "no space (6A84)"] + [(= n SW-COMMAND-ABORTED) "command aborted (6F00)"] + [(= n SW-COMMAND-NOT-ALLOWED) "command not allowed (6986)"] + [(= n SW-INS-NOT-SUPPORTED) "INS not supported (6D00)"] + [(= n SW-CLA-NOT-SUPPORTED) "CLA not supported (6E00)"] + [(= n SW-FILE-NOT-FOUND) "file/applet not found (6A82)"] + [else (format "SW=~4,'0x" n)])) + + ;; --- APDU encoder --- + + ;; Build a short-form APDU. + ;; cla, ins, p1, p2 :: byte + ;; data :: bytevector or #f + ;; le :: nonneg integer or #f (omit Le entirely) + ;; + ;; If both data and le are #f the body is just CLA|INS|P1|P2. + ;; If data is present, Lc = (bytevector-length data). + ;; If le is present (and ≤256), Le byte: 0 means 256. + ;; + ;; Extended-length form is supported for data > 255: encoded as + ;; "00 LH LL <data> [00 LEH LEL]". YubiKey accepts both forms. + (def (apdu cla ins p1 p2 . opts) + (let* ([data (if (pair? opts) (car opts) #f)] + [le (if (and (pair? opts) (pair? (cdr opts))) (cadr opts) #f)] + [hdr (bv cla ins p1 p2)]) + (cond + ;; Case 1: no data, no Le. + [(and (not data) (not le)) hdr] + ;; Case 2: no data, Le only (a read-only request). + [(not data) + (cond + [(and (>= le 0) (<= le 256)) + (bv-append hdr (bv (if (= le 256) 0 le)))] + [(<= le 65536) + (bv-append hdr (bv 0 + (bitwise-and (bitwise-arithmetic-shift-right le 8) #xff) + (bitwise-and le #xff)))] + [else (yk-error 'apdu "Le too large: ~d" le)])] + ;; Case 3 / 4: with data, possibly with Le. + [else + (let* ([lc (bytevector-length data)] + [lc-bytes (cond + [(= lc 0) (bv 0)] + [(< lc 256) (bv lc)] + [(< lc 65536) + (bv 0 + (bitwise-and (bitwise-arithmetic-shift-right lc 8) #xff) + (bitwise-and lc #xff))] + [else (yk-error 'apdu "Lc too large: ~d" lc)])] + [le-bytes (cond + [(not le) #vu8()] + [(< lc 256) + (bv (if (= le 256) 0 le))] + [else + ;; If Lc was extended, Le must match. + (bv (bitwise-and (bitwise-arithmetic-shift-right le 8) #xff) + (bitwise-and le #xff))])]) + (bv-append hdr lc-bytes data le-bytes))]))) + + ;; --- Common APDUs --- + + ;; SELECT by AID: 00 A4 04 00 <Lc> <AID> + ;; (CLA = 0; P1=04 = select by name; P2=00 = first/only occurrence) + (def (apdu-select aid) + (apdu #x00 INS-SELECT #x04 #x00 aid)) + + ;; ISO GET RESPONSE: 00 C0 00 00 <Le> + (def (apdu-get-response le) + (apdu #x00 INS-GET-RESPONSE #x00 #x00 #f (if (= le 0) 256 le)))