From be6987c1eb4c7e84753acefa5146f6d3043028de Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonygarnockjones@gmail.com>
Date: Wed, 23 Sep 2015 22:01:45 -0400
Subject: [PATCH] Hex-encoded DB keys to avoid subdirectory escape attacks

---
 src/package-catalog/db.rkt | 36 +++++++++++++++++++++---------------
 1 file changed, 21 insertions(+), 15 deletions(-)

diff --git a/src/package-catalog/db.rkt b/src/package-catalog/db.rkt
index e12847a..884c030 100644
--- a/src/package-catalog/db.rkt
+++ b/src/package-catalog/db.rkt
@@ -9,6 +9,7 @@
          db-keys)
 
 (require racket/file)
+(require file/sha1)
 
 (struct db (name path serializer deserializer) #:transparent)
 
@@ -20,27 +21,32 @@
   (unless (string? key)
     (error what "Invalid key for db ~a: ~v" (db-name db) key)))
 
-(define (db-has-key? db key)
-  (check-key 'db-has-key? db key)
-  (file-exists? (build-path (db-path db) key)))
+;; We avoid potential filesystem subdirectory escape attacks by
+;; encoding key paths into hex. Special characters in keys are thus
+;; permitted and rendered harmless.
+(define (key->path what db key)
+  (check-key what db key)
+  (build-path (db-path db) (bytes->hex-string (string->bytes/utf-8 key))))
 
-(define (db-ref db key default-thunk)
-  (check-key 'db-ref db key)
-  (define p (build-path (db-path db) key))
-  (if (file-exists? p)
-      ((db-deserializer db) (file->value p))
-      (default-thunk)))
+(define (db-has-key? db key)
+  (file-exists? (key->path 'db-has-key? db key)))
+
+(define (db-ref db key default)
+  (define p (key->path 'db-ref db key))
+  (cond
+    [(file-exists? p) ((db-deserializer db) (file->value p))]
+    [(procedure? default) (default)]
+    [else default]))
 
 (define (db-set! db key value)
-  (check-key 'db-set! db key)
-  (write-to-file value (build-path (db-path db) key)
-                 #:exists 'replace))
+  (define p (key->path 'db-set! db key))
+  (write-to-file ((db-serializer db) value) p #:exists 'replace))
 
 (define (db-remove! db key)
-  (check-key 'db-remove! db key)
-  (define p (build-path (db-path db) key))
+  (define p (key->path 'db-remove! db key))
   (when (file-exists? p)
     (delete-file p)))
 
 (define (db-keys db)
-  (map path->string (directory-list (db-path db))))
+  (map (lambda (p) (bytes->string/utf-8 (hex-string->bytes (path->string p))))
+       (directory-list (db-path db))))