From e27c51698b71de3cfdbfa9e1d8308aa23e66bdef Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Mon, 2 Jun 2014 14:34:22 +0100
Subject: [PATCH] net/url: add `relative-path->relative-url-string`

---
 pkgs/net-pkgs/net-doc/net/scribblings/url.scrbl | 11 +++++++++++
 pkgs/net-pkgs/net-test/tests/net/url.rkt        | 15 +++++++++++++++
 racket/collects/net/url.rkt                     | 16 ++++++++++++++++
 3 files changed, 42 insertions(+)

diff --git a/pkgs/net-pkgs/net-doc/net/scribblings/url.scrbl b/pkgs/net-pkgs/net-doc/net/scribblings/url.scrbl
index 0a9749d8c7..3435274752 100644
--- a/pkgs/net-pkgs/net-doc/net/scribblings/url.scrbl
+++ b/pkgs/net-pkgs/net-doc/net/scribblings/url.scrbl
@@ -194,6 +194,17 @@ Converts @racket[URL], which is assumed to be a @racket["file"] URL,
 to a path.}
 
 
+@defproc[(relative-path->relative-url-string [path (and/c (or/c path-string? path-for-some-system?)
+                                                          relative-path?)])
+         string?]{
+
+Converts @racket[path] to a string that parses as a relative URL (with
+forward slashes). Each element of @racket[path] is an element of the
+resulting URL path, and the string form of each element is encoded as
+needed. If @racket[path] is syntactically a directory, then the resulting
+URL ends with @litchar{/}.}
+
+
 @defparam[file-url-path-convention-type kind (or/c 'unix 'windows)]{
 
 Determines the default conversion to and from strings for
diff --git a/pkgs/net-pkgs/net-test/tests/net/url.rkt b/pkgs/net-pkgs/net-test/tests/net/url.rkt
index f992917459..5b2dd51026 100644
--- a/pkgs/net-pkgs/net-test/tests/net/url.rkt
+++ b/pkgs/net-pkgs/net-test/tests/net/url.rkt
@@ -377,6 +377,21 @@
 
      ))
 
+  (test (relative-path->relative-url-string "a")
+        => "a")
+  (test (relative-path->relative-url-string "a/")
+        => "a/")
+  (test (relative-path->relative-url-string "a/b")
+        => "a/b")
+  (test (relative-path->relative-url-string (build-path "a" 'up "b"))
+        => "a/../b")
+  (test (relative-path->relative-url-string (build-path "a" 'same "b" 'up))
+        => "a/./b/../")
+  (test (relative-path->relative-url-string (build-path "a&c;" 'same "b"))
+        => "a%26c%3B/./b")
+  (test (relative-path->relative-url-string (bytes->path '#"\\\\?\\REL\\a\\b/c\\d" 'windows))
+        => "a/b%2Fc/d")
+
   )
 
 (module+ test (require (submod ".." main))) ; for raco test & drdr
diff --git a/racket/collects/net/url.rkt b/racket/collects/net/url.rkt
index 5122435ef3..add6bb46ee 100644
--- a/racket/collects/net/url.rkt
+++ b/racket/collects/net/url.rkt
@@ -593,6 +593,19 @@
               (if (null? url-tail) url-path (append url-path url-tail))
               '() #f)))
 
+(define (relative-path->relative-url-string path)
+  (define s (string-join (for/list ([e (in-list (explode-path path))])
+                           (cond
+                            [(eq? e 'same) "."]
+                            [(eq? e 'up) ".."]
+                            [else
+                             (uri-encode* (path-element->string e))]))
+                         "/"))
+  ;; Add "/" to reflect directory-ness:
+  (let-values ([(base name dir?) (split-path path)])
+    (if dir?
+        (string-append s "/")
+        s)))
 
 (define (url->path url [kind (system-path-convention-type)])
   (file://->path url kind))
@@ -688,6 +701,9 @@
                                (not/c #rx"^[^:/?#]*:")))
                   url?))
  (path->url ((or/c path-string? path-for-some-system?) . -> . url?))
+ (relative-path->relative-url-string ((and/c (or/c path-string? path-for-some-system?)
+                                             relative-path?)
+                                      . -> . string?))
  (url->string (url? . -> . string?))
  (url->path (->* (url?) ((one-of/c 'unix 'windows)) path-for-some-system?))