fix: no-follow writes, bytevector-copy! performance, PID locking, vault permissions, glob ReDoS
ober
ca184e907d9ac32e5398d54bc7e551101e461b2d
--- a/protonstorage/drive/credentials.ss +++ b/protonstorage/drive/credentials.ss @@ -14,6 +14,8 @@ (except (jerboa prelude) meta atom? partition sort sort! make-date make-time read-file-string) + (only (std os posix) posix-open posix-close posix-write + O_WRONLY O_CREAT O_TRUNC) (only (std security taint) safe-delete-file) (only (std text json) json-object->string string->json-object) (only (std text base64) base64-string->u8vector u8vector->base64-string) @@ -96,13 +98,15 @@ (define (write-vault-file-string path text) (let ([path (nonempty-string 'write-vault-file-string 'path path)]) - (call-with-port - (open-file-output-port - path - (file-options no-fail) - (buffer-mode block) - (native-transcoder)) - (lambda (p) (display text p))))) + ;; Create the vault file with 0600 permissions explicitly (rather than + ;; the process umask default) so the encrypted credentials are never + ;; group/world readable, even momentarily. + (let* ([data (string->utf8 text)] + [fd (posix-open path + (bitwise-ior O_WRONLY O_CREAT O_TRUNC) #o600)]) + (guard (e [#t (posix-close fd) (raise e)]) + (posix-write fd data (bytevector-length data)) + (posix-close fd))))) (define (delete-vault-file-if-exists path) (let ([path (nonempty-string 'delete-vault-file-if-exists 'path path)]) --- a/protonstorage/drive/local.ss +++ b/protonstorage/drive/local.ss @@ -16,10 +16,12 @@ (except (jerboa prelude) meta atom? partition sort sort! make-date make-time read-file-string string-suffix? path-join) - (only (jerboa core) - getenv getpid create-directory directory-files - file-info file-info-size) - (only (std security taint) safe-delete-file)) + (only (jerboa core) + getenv getpid create-directory directory-files + file-info file-info-size) + (only (std os posix) posix-open posix-close O_RDWR O_CREAT) + (only (std os flock) flock-try-exclusive) + (only (std security taint) safe-delete-file)) (define (json-object . fields) (let ([ht (make-hashtable equal-hash equal?)]) @@ -244,9 +246,25 @@ "IndexedCacheStatesImplemented" #f "Paths" paths))) + ;; Held for the daemon's lifetime between record-mount-start! and + ;; record-mount-stop!; closing it releases the advisory PID file lock. + (define *pid-lock-fd* #f) + (define (proton-drive-record-mount-start! profile state-root mountpoint writeable?) (let* ([paths (proton-drive-ensure-local-profile! profile state-root)] - [mode (if writeable? "read-write" "read-only")]) + [mode (if writeable? "read-write" "read-only")] + [pid-path (profile-marker-file-path paths "PidFile")]) + ;; Take an exclusive non-blocking flock on the PID file and hold it for + ;; the daemon's lifetime. The lock is released when *pid-lock-fd* is + ;; closed on mount-stop (or automatically on process exit), so a + ;; concurrent start fails fast instead of silently overwriting the + ;; running daemon's PID, and a crash leaves no stale lock behind. + (let ([lock-fd (posix-open pid-path (bitwise-ior O_RDWR O_CREAT) #o644)]) + (unless (flock-try-exclusive lock-fd) + (posix-close lock-fd) + (error 'proton-drive-record-mount-start! + "another daemon already holds the PID file lock" pid-path)) + (set! *pid-lock-fd* lock-fd)) (write-profile-marker-file paths "PidFile" @@ -257,6 +275,11 @@ (define (proton-drive-record-mount-stop! profile state-root) (let ([paths (proton-drive-local-profile-paths profile state-root)]) + ;; Release the advisory PID file lock held since mount-start. + (when *pid-lock-fd* + (guard (e [(condition? e) #f]) + (posix-close *pid-lock-fd*)) + (set! *pid-lock-fd* #f)) (delete-profile-marker-file-if-exists paths "PidFile") (delete-profile-marker-file-if-exists paths "MountpointFile") (delete-profile-marker-file-if-exists paths "ModeFile") --- a/protonstorage/drive/write.ss +++ b/protonstorage/drive/write.ss @@ -46,7 +46,8 @@ (except (jerboa prelude) meta atom? partition sort sort! make-date make-time read-file-string) - (only (jerboa core) getenv make-mutex mutex-lock! mutex-unlock! spawn) + (only (jerboa core) getenv make-mutex mutex-lock! mutex-unlock! spawn + make-condition-variable condition-variable-broadcast!) (only (std text base64) u8vector->base64-string) (only (std text json) json-object->string) (jerboa-crypto) @@ -443,6 +444,7 @@ [linkv (list->vector links)] [results (make-vector block-count upload-worker-pending-marker)] [mutex (make-mutex 'proton-drive-upload-blocks)] + [cv (make-condition-variable)] [next-index 0] [active 0] [completed 0] @@ -469,7 +471,8 @@ (when (and (not first-error) (and (pair? result) (eq? (car result) 'error))) - (set! first-error (cdr result)))))))))] + (set! first-error (cdr result))) + (condition-variable-broadcast! cv)))))))] [schedule! (lambda () (let loop () @@ -479,27 +482,27 @@ (let ([index next-index]) (set! next-index (+ next-index 1)) (start-worker! index) - (loop)))))] - [state! - (lambda () - (call-with-upload-mutex - mutex - (lambda () - (schedule!) - (cond - [(and first-error (= active 0)) - (cons 'error first-error)] - [(= completed block-count) 'done] - [else 'wait]))))]) + (loop)))))]) (let loop () - (let ([state (state!)]) + (mutex-lock! mutex) + (schedule!) + (let ([state + (cond + [(and first-error (= active 0)) + (cons 'error first-error)] + [(= completed block-count) 'done] + [else 'wait])]) (cond [(eq? state 'done) + (mutex-unlock! mutex) (upload-result-list results)] [(and (pair? state) (eq? (car state) 'error)) + (mutex-unlock! mutex) (raise (cdr state))] [else - (sleep-ms 50) + ;; Atomically release the mutex and wait for a worker to + ;; broadcast progress; replaces the busy-wait poll. + (mutex-unlock! mutex cv) (loop)])))))))) (def (upload-block-pairs! blocks links) --- a/protonstorage/s3/drive.ss +++ b/protonstorage/s3/drive.ss @@ -256,10 +256,7 @@ (define (jdrive-bytevector-slice bv start end) (let* ([len (- end start)] [out (make-bytevector len 0)]) - (let loop ([i 0]) - (when (< i len) - (bytevector-u8-set! out i (bytevector-u8-ref bv (+ start i))) - (loop (+ i 1)))) + (bytevector-copy! bv start out 0 len) out)) (define (bytevectors-length bvs) @@ -275,10 +272,7 @@ (unless (null? xs) (let* ([bv (car xs)] [len (bytevector-length bv)]) - (let inner ([i 0]) - (when (< i len) - (bytevector-u8-set! out (+ offset i) (bytevector-u8-ref bv i)) - (inner (+ i 1)))) + (bytevector-copy! bv 0 out offset len) (outer (cdr xs) (+ offset len))))) out)) @@ -698,21 +692,32 @@ (lambda () (free-digest-ctx ctx))))) (define (glob-match? pattern text) + ;; Iterative greedy matcher with a single recorded '*' backtrack point. + ;; Runs in O(plen*tlen) worst case with no exponential backtracking, so a + ;; crafted pattern like "*a*a*a*a*b" cannot trigger ReDoS on a long text. (let ([plen (string-length pattern)] [tlen (string-length text)]) - (letrec - ([match - (lambda (pi ti) - (cond - [(= pi plen) (= ti tlen)] - [(char=? (string-ref pattern pi) #\*) - (or (match (+ pi 1) ti) - (and (< ti tlen) (match pi (+ ti 1))))] - [(and (< ti tlen) - (char=? (string-ref pattern pi) (string-ref text ti))) - (match (+ pi 1) (+ ti 1))] - [else #f]))]) - (match 0 0)))) + (let loop ([pi 0] [ti 0] [star-pi -1] [match-ti 0]) + (cond + [(< ti tlen) + (cond + [(and (< pi plen) (char=? (string-ref pattern pi) #\*)) + ;; Record the star and first try matching it to the empty string. + (loop (+ pi 1) ti pi ti)] + [(and (< pi plen) + (char=? (string-ref pattern pi) (string-ref text ti))) + (loop (+ pi 1) (+ ti 1) star-pi match-ti)] + [(not (= star-pi -1)) + ;; Mismatch: let the last star consume one more text byte. + (loop (+ star-pi 1) (+ match-ti 1) star-pi (+ match-ti 1))] + [else #f])] + [else + ;; Text consumed; only trailing '*' may remain in the pattern. + (let drain ([pi pi]) + (cond + [(= pi plen) #t] + [(char=? (string-ref pattern pi) #\*) (drain (+ pi 1))] + [else #f]))])))) (define (any-pattern-matches? patterns text) (let loop ([xs patterns]) @@ -2276,7 +2281,19 @@ remote-path offset size)]) - (write-file-bytes local-path data) + ;; Write via the descriptor-relative secure output transaction (the same + ;; no-follow path recursive downloads use) so a symlink at local-path + ;; cannot redirect the decrypted bytes elsewhere. + (let ([root-handle (secure-directory-open (parent-directory local-path) #t)] + [name (path-basename local-path)]) + (dynamic-wind + (lambda () (void)) + (lambda () + (call-with-secure-output-file + root-handle + name + (lambda (out) (put-bytevector out data)))) + (lambda () (secure-directory-close root-handle)))) (json-object "Backend" "s3" "Profile" (jdrive-s3-profile-name profile)