drive: close storage-host allow-list userinfo bypass (pm-storage-token leak)

ober

bb6c50fc156a334f7727c9077001c52d218cb0f0

diff --git a/protonstorage/drive/api.ss b/protonstorage/drive/api.ss
index e5d3361..e113f6f 100644
--- a/protonstorage/drive/api.ss
+++ b/protonstorage/drive/api.ss
@@ -516,7 +516,8 @@
            (substring url 0 i)]
           [else (loop (+ i 1))]))))
 
-  (def (storage-url-host url)
+  (def (storage-url-authority url)
+    ;; The authority component: between "://" and the first "/", "?", or "#".
     (let* ([n (string-length url)]
            [start
             (let loop ([i 0])
@@ -529,11 +530,43 @@
              (cond
                [(= i n) (substring url start n)]
                [(let ([c (string-ref url i)])
-                  (or (char=? c #\/) (char=? c #\:)
-                      (char=? c #\?) (char=? c #\#)))
+                  (or (char=? c #\/) (char=? c #\?) (char=? c #\#)))
                 (substring url start i)]
                [else (loop (+ i 1))])))))
 
+  (def (storage-url-userinfo? url)
+    ;; True when the authority carries a "userinfo@" component.
+    (let ([authority (storage-url-authority url)])
+      (and authority
+           (let loop ([i 0])
+             (and (< i (string-length authority))
+                  (or (char=? (string-ref authority i) #\@)
+                      (loop (+ i 1))))))))
+
+  (def (storage-url-host url)
+    (let ([authority (storage-url-authority url)])
+      (and authority
+           (let* ([an (string-length authority)]
+                  ;; Drop any userinfo component: the host is what follows the
+                  ;; last '@'. Ignoring '@' let "https://proton.me:443@evil.com"
+                  ;; parse as host "proton.me" while a conformant client connects
+                  ;; to "evil.com", leaking the pm-storage-token (URL confusion).
+                  [hostport
+                   (let loop ([j (- an 1)])
+                     (cond
+                       [(< j 0) authority]
+                       [(char=? (string-ref authority j) #\@)
+                        (substring authority (+ j 1) an)]
+                       [else (loop (- j 1))]))]
+                  [hn (string-length hostport)])
+             ;; Drop the port; storage hosts are DNS names (no IPv6 literals).
+             (let loop ([k 0])
+               (cond
+                 [(= k hn) hostport]
+                 [(char=? (string-ref hostport k) #\:)
+                  (substring hostport 0 k)]
+                 [else (loop (+ k 1))]))))))
+
   (def (string-downcase-ascii value)
     (list->string (map char-downcase (string->list value))))
 
@@ -567,6 +600,13 @@
         (error 'proton-drive-assert-storage-url-allowed!
                "storage BareURL must use an https:// scheme"
                bare-url))
+      ;; Storage block URLs never carry credentials; refuse any userinfo so a
+      ;; URL like "https://proton.me:443@evil.com" cannot smuggle a foreign host
+      ;; past the allow-list (the pm-storage-token is sent to the real host).
+      (when (storage-url-userinfo? bare-url)
+        (error 'proton-drive-assert-storage-url-allowed!
+               "storage BareURL must not contain userinfo"
+               bare-url))
       (unless (storage-host-allowed? host (proton-drive-storage-host-allowlist))
         (error 'proton-drive-assert-storage-url-allowed!
                "storage BareURL host is not allow-listed for the pm-storage-token"
diff --git a/test/test-all.ss b/test/test-all.ss
index a474db4..05f0343 100644
--- a/test/test-all.ss
+++ b/test/test-all.ss
@@ -1046,6 +1046,37 @@
          "secret-storage-token"
          (string->utf8 "encrypted-block")))
 
+;; Regression: a "userinfo@" authority must not smuggle a foreign host past the
+;; allow-list. "https://proton.me:443@evil.com" parses (RFC 3986) as userinfo
+;; "proton.me:443" and host "evil.com"; a naive host scan that stops at ":" saw
+;; "proton.me" and leaked the pm-storage-token to evil.com.
+(check-error-contains "block download rejects userinfo URL smuggling a foreign host"
+       "userinfo"
+       (proton-drive-get-block-bytes
+         "https://proton.me:443@evil.com/blocks/1"
+         "secret-storage-token"))
+
+(check-error-contains "block upload rejects userinfo URL smuggling a foreign host"
+       "userinfo"
+       (proton-drive-upload-block
+         "https://proton.me@evil.com/blocks/1"
+         "secret-storage-token"
+         (string->utf8 "encrypted-block")))
+
+(check "storage URL allow-list ignores userinfo/port; legit https host still accepted"
+       (and (test-raises?
+              (lambda ()
+                (proton-drive-assert-storage-url-allowed!
+                  "https://proton.me:443@evil.com/blocks/1")))
+            (test-raises?
+              (lambda ()
+                (proton-drive-assert-storage-url-allowed!
+                  "https://user:pw@evil.com#.proton.me")))
+            (string=?
+              (proton-drive-assert-storage-url-allowed!
+                "https://storage.proton.me:443/blocks/1")
+              "https://storage.proton.me:443/blocks/1")))
+
 (check "drive status records signature and storage URL enforcement"
        (let* ([caps (hashtable-ref (proton-drive-status) "ImplementedCapabilities" '())])
          (and (member "content-key-packet-signature-enforcement" caps)