drive: require https + allow-listed storage host for block transfer

ober

e40ff223571448b32eafdec0292a8aa26531ace5

diff --git a/protonstorage/drive/api.ss b/protonstorage/drive/api.ss
index 5c89b51..e5d3361 100644
--- a/protonstorage/drive/api.ss
+++ b/protonstorage/drive/api.ss
@@ -33,7 +33,9 @@
     proton-drive-request-block-upload
     proton-drive-block-upload-multipart-body
     proton-drive-upload-block
-    proton-drive-get-block-bytes)
+    proton-drive-get-block-bytes
+    proton-drive-storage-host-allowlist
+    proton-drive-assert-storage-url-allowed!)
 
   (import (rnrs)
           (except (jerboa prelude)
@@ -207,7 +209,11 @@
         "encrypted-credential-vault"
         "folder-path-resolution"
         "folder-trash-command"
-        "block-upload-multipart")
+        "block-upload-multipart"
+        "content-key-packet-signature-enforcement"
+        "drive-block-signature-enforcement"
+        "revision-manifest-signature-enforcement"
+        "storage-url-allowlist-enforcement")
       "DisabledCapabilities"
       '("raw-openpgp-content-session-key-decrypt"
         "content-key-signature-verification"
@@ -490,7 +496,85 @@
               (string-append "\r\n--" boundary "--\r\n"))])
       (bytevector-append prefix encrypted-block suffix)))
 
+  (define *proton-drive-storage-host-allowlist* '("proton.me"))
+
+  (define (proton-drive-storage-host-allowlist . maybe-value)
+    (cond
+      [(null? maybe-value) *proton-drive-storage-host-allowlist*]
+      [(null? (cdr maybe-value))
+       (set! *proton-drive-storage-host-allowlist* (car maybe-value))]
+      [else
+       (error 'proton-drive-storage-host-allowlist
+              "expected zero or one argument")]))
+
+  (def (storage-url-scheme url)
+    (let ([n (string-length url)])
+      (let loop ([i 0])
+        (cond
+          [(> (+ i 3) n) #f]
+          [(string=? (substring url i (+ i 3)) "://")
+           (substring url 0 i)]
+          [else (loop (+ i 1))]))))
+
+  (def (storage-url-host url)
+    (let* ([n (string-length url)]
+           [start
+            (let loop ([i 0])
+              (cond
+                [(> (+ i 3) n) #f]
+                [(string=? (substring url i (+ i 3)) "://") (+ i 3)]
+                [else (loop (+ i 1))]))])
+      (and start
+           (let loop ([i start])
+             (cond
+               [(= i n) (substring url start n)]
+               [(let ([c (string-ref url i)])
+                  (or (char=? c #\/) (char=? c #\:)
+                      (char=? c #\?) (char=? c #\#)))
+                (substring url start i)]
+               [else (loop (+ i 1))])))))
+
+  (def (string-downcase-ascii value)
+    (list->string (map char-downcase (string->list value))))
+
+  (def (string-suffix-ci? value suffix)
+    (let ([n (string-length value)]
+          [m (string-length suffix)])
+      (and (>= n m)
+           (string=? (substring value (- n m) n) suffix))))
+
+  (def (storage-host-allowed? host allowlist)
+    (and (string? host)
+         (> (string-length host) 0)
+         (not (string-suffix-ci? host "@"))
+         (let ([host (string-downcase-ascii host)])
+           (let loop ([xs allowlist])
+             (cond
+               [(null? xs) #f]
+               [(let ([entry (string-downcase-ascii (car xs))])
+                  (or (string=? host entry)
+                      (string-suffix-ci? host (string-append "." entry))))
+                #t]
+               [else (loop (cdr xs))])))))
+
+  (def (proton-drive-assert-storage-url-allowed! bare-url)
+    (unless (string? bare-url)
+      (error 'proton-drive-assert-storage-url-allowed!
+             "storage BareURL must be a string"))
+    (let ([scheme (storage-url-scheme bare-url)]
+          [host (storage-url-host bare-url)])
+      (unless (and scheme (string=? (string-downcase-ascii scheme) "https"))
+        (error 'proton-drive-assert-storage-url-allowed!
+               "storage BareURL must use an https:// scheme"
+               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"
+               bare-url))
+      bare-url))
+
   (def (proton-drive-upload-block bare-url token encrypted-block)
+    (proton-drive-assert-storage-url-allowed! bare-url)
     (let* ([boundary proton-drive-block-upload-boundary]
            [body (proton-drive-block-upload-multipart-body
                    encrypted-block
@@ -513,6 +597,7 @@
                  (response-error-message status text)))))
 
   (def (proton-drive-get-block-bytes bare-url token)
+    (proton-drive-assert-storage-url-allowed! bare-url)
     (let* ([headers (list (proton-api-header "pm-storage-token" token))]
            [req (http-get bare-url 'headers: headers)]
            [status (request-status req)]