New middleware: with-context, ignore-trailing-slash, with-uri-rewrite.

Signed-off-by: James Reeves <jreeves@weavejester.com>

Author: lrenn

src/compojure/http/middleware.clj

@@ -46,9 +46,51 @@
    (with-headers handler
      {"Cache-Control" (header-options header-map ", ")}))
 
+(defn with-uri-rewrite
+  "Rewrites a request uri with the result of calling f with the
+   request's original uri.  If f returns nil the handler is not called."
+  [handler f]
+  (fn [request]
+    (let [uri (:uri request)
+          rewrite (f uri)]
+      (if rewrite
+        (handler (assoc request :uri rewrite))
+        nil))))
+
+(defn- remove-or-nil-context
+  "Removes a context string from the front of a uri.  If it wasn't there,
+   returns nil."
+  [uri context]
+  (if (.startsWith uri context)
+    (if-not (= uri context)
+      (subs uri (count context))
+      "/")
+    nil))
+
+(defn with-context
+  "Removes the context string from the beginning of the request uri
+   such that route matching is done without it.  If the context is not
+   present, the handler will not be called."
+  [handler context]
+  (with-uri-rewrite handler #(remove-or-nil-context % context)))
+
+(defn- uri-snip-slash
+  "Removes a trailing slash from all uris except \"/\"."
+  [uri]
+  (if (and (not (= "/" uri))
+           (.endsWith uri "/"))
+    (chop uri)
+    uri))
+
+(defn ignore-trailing-slash
+  "Makes routes match regardless of whether or not a uri ends in a slash."
+  [handler]
+  (with-uri-rewrite handler uri-snip-slash))
+
 (defvar default-mimetypes
   {"css"  "text/css"
    "gif"  "image/gif"
+   "gz"   "application/gzip"
    "htm"  "text/html"
    "html" "text/html"
    "jpg"  "image/jpeg"

test/compojure/http/middleware.clj

@@ -51,10 +51,45 @@
       (is (= "max-age=3600, must-revalidate"
              (get (:headers response) "Cache-Control"))))))
 
+(defn run-ignore-trailing-slash-paths
+  [route-path uri]
+  (let [routes  (routes (GET route-path "foo"))
+        request {:request-method :get
+                 :uri uri}
+        response ((ignore-trailing-slash routes) request)]
+    (= (:body response) "foo")))
+
+(deftest test-ignore-trailing-slash-paths
+  (are (run-ignore-trailing-slash-paths _1 _2)
+       "/" "/"
+       "/foo" "/foo"
+       "/foo" "/foo/"
+       "/foo/bar" "/foo/bar/"))
+
+(defn run-with-context
+  [route-path uri context]
+  (let [routes  (routes (GET route-path "foo"))
+        request {:request-method :get
+                 :uri uri}
+        response ((with-context routes context) request)]
+    (= (:body response) "foo")))
+
+(deftest test-with-context
+  (are (run-with-context _1 _2 "/context")
+       "/" "/context"
+       "/home" "/context/home"
+       "/asset/1" "/context/asset/1"))
+
+(deftest test-without-context
+  (are (not (run-with-context _1 _2 "/context"))
+       "/" "/"
+       "/home" "/home"
+       "/asset/1" "/asset/1"))
+
 (defn run-mimetypes
   [uri type options]
   (let [routes  (routes (GET uri "foo"))
-        request {:request-method :get,
+        request {:request-method :get
                  :uri uri}
         response ((with-mimetypes routes options) request)
         result (get (:headers response) "Content-Type")]