URLs generated by wrap-trace middleware should be aware of the context

src/liberator/dev.clj

@@ -26,6 +26,14 @@
 
 (def ^:dynamic *current-id* nil)
 
+(def ^:dynamic *context* nil)
+
+(defn wrap-context
+  [handler]
+  (fn [request]
+    (binding [*context* (:context request "")]
+      (handler request))))
+
 (defn seconds-ago [d]
   (int  (/ (- ( System/currentTimeMillis) (.getTime d)) 1000)))
 
@@ -57,7 +65,7 @@
                "var svg = document.getElementById(\"trace\").contentDocument;\n"
                "var style = svg.createElementNS(\"http://www.w3.org/2000/svg\",\"style\"); "
                (str  "style.textContent = '"
-                     (clojure.string/replace 
+                     (clojure.string/replace
                       (slurp (clojure.java.io/resource "liberator/trace.css"))
                       #"[\r\n]" " ") "'; ")
                "var root = svg.getElementsByTagName(\"svg\")[0];"
@@ -74,15 +82,15 @@
                                (format
                                 "svg.getElementById(\"%s\").setAttribute(\"class\", svg.getElementById(\"%s\").getAttribute(\"class\") + \" %s\");" id id (if (result->bool r1) "hl-true" "hl-false"))))
                           (map vector log (rest log))))
-               
+
                "};"
                "setTimeout(function(){insertStyle()}, 500);"
                "setTimeout(function(){insertStyle()}, 1000);"
                "setTimeout(function(){insertStyle()}, 5000);"
-               
+
                ""])]
        [:body
-        [:a {:href mount-url} "List of all traces"]
+        [:a {:href (str *context* mount-url)} "List of all traces"]
         [:h1 "Liberator Request Trace #" id " at " d " (" (seconds-ago d) "s ago)"]
         [:h2 "Request was "" [:span {:style "text-transform: uppercase"}
                                    (:request-method r)] " " [:span (:uri r)] """]
@@ -94,10 +102,10 @@
         [:ol (map (fn [[l [n r]]] [:li (h l) ": " (h n) " "
                                   (if (nil? r) [:em "nil"] (h (pr-str r)))]) log)]
         [:div {:style "text-align: center;"}
-         [:object {:id "trace" :data (str mount-url "trace.svg") :width "90%"
+         [:object {:id "trace" :data (str *context* mount-url "trace.svg") :width "90%"
                    :style "border: 1px solid #666;"}]]
 
-        
+
         [:h3 "Full Request"]
         [:pre [:tt (h (with-out-str (clojure.pprint/pprint r)))]]])
       "application/json"
@@ -114,11 +122,11 @@
     (html5 [:head [:title "Liberator Request Trace #" id " not found."]]
            [:body [:h1 "Liberator Request Trace #" id " not found."]
             [:p "The requested trace was not found. Maybe it is expired."]
-            [:p "You can access a " [:a {:href mount-url} "list of traces"] "."]])))
+            [:p "You can access a " [:a {:href (str *context* mount-url)} "list of traces"] "."]])))
 
 (defresource list-handler
   :available-media-types ["text/html"]
-  :handle-ok (fn [_] 
+  :handle-ok (fn [_]
                (html5
                 [:head
                  [:title "Liberator Request Traces"]]
@@ -132,11 +140,11 @@
                      " header in the http response."]]
                    [:ol (map (fn [[id [d {:keys [request-method uri]} log]]]
                                [:ul
-                                [:a {:href (h (str (with-slash mount-url) id))}
+                                [:a {:href (h (str (with-slash (str *context* mount-url)) id))}
                                  [:span (h request-method)] " " [:span (h uri)]]
                                 [:span " at " [:span (h d)] " " [:span "(" (seconds-ago d) "s ago)"]]]) @logs)])])))
 
-(defn css-url [] (str (with-slash mount-url) "styles.css"))
+(defn css-url [] (str (with-slash (str *context* mount-url)) "styles.css"))
 
 (defn include-trace-css []
   (include-css (css-url)))
@@ -145,7 +153,7 @@
   "Build the url under which the trace information can be found for the
    given trace id"
   [id]
-  (str (with-slash mount-url) id))
+  (str (with-slash (str *context* mount-url)) id))
 
 (defn current-trace-url
   "Return the url under with the trace of the current request can be accessed"
@@ -163,11 +171,11 @@
   :available-media-types ["text/css"]
   :handle-ok "#x-liberator-trace {
   display:block;
-  
+
   position:absolute;
   top:0;
   right:0;
-  
+
   margin-top: 1em;
   margin-right: 1em;
   padding: 0 1em;
@@ -187,7 +195,7 @@
 (defn- wrap-trace-ui [handler]
   (let [base-url (with-slash mount-url)]
     (routes
-     ;;           (fn [_] 
+     ;;           (fn [_]
      (GET (str base-url "trace.svg") [] (fn [_]  trace-svg))
      (ANY (str base-url "styles.css") [] styles)
      (ANY [(str base-url ":id") :id #".+"] [id] #((log-handler id) %))
@@ -221,7 +229,7 @@
    :ui     - Include link to a resource that dumps the current request
    :header - Include full trace in response header"
   [handler & opts]
-  (-> 
+  (->
    (fn [request]
      (let [request-log (atom [])]
        (binding [*current-id* (next-id)]
@@ -235,5 +243,5 @@
                              @request-log])
                  (assoc-in resp [:headers trace-id-header] *current-id*))
                resp))))))
-   (cond-wrap (some #{:ui} opts) wrap-trace-ui)
-   (cond-wrap (some #{:header} opts) wrap-trace-header)))
+   (cond-wrap (some #{:ui} opts) (comp wrap-context wrap-trace-ui))
+   (cond-wrap (some #{:header} opts) (comp wrap-context wrap-trace-header))))