Fix context/path-info for upgrades [IMMUTANT-521]

This uses reflection, which isn't ideal. You only pay for it if you need
it, since request entries are delays, but the larger issue is the
reflection in the servlet impl ties us to specific data members in
Undertow classes. We can probably come up with an extension of
HandshakeRequest in wboss to mitigate this, though.

web/dev-resources/testing/app.clj

@@ -45,7 +45,11 @@
 
 (defn dump
   [request]
-  (response (encode (dissoc request :server-exchange :body :servlet :servlet-request :servlet-response :servlet-context))))
+  (let [data (encode (dissoc request :server-exchange :body :servlet
+                       :servlet-request :servlet-response :servlet-context))]
+    (if (:websocket? request)
+      (async/as-channel request :on-open (fn [ch] (async/send! ch data)))
+      (response data))))
 
 (defn with-charset [request]
   (let [[_ cs] (re-find #"charset=(.*)" (:query-string request))
@@ -105,7 +109,6 @@
   (GET "/" [] counter)
   (GET "/session" {s :session} (encode s))
   (GET "/unsession" [] {:session nil})
-  (GET "/request" [] dump)
   (GET "/charset" [] with-charset)
   (GET "/chunked-stream" [] chunked-stream)
   (GET "/non-chunked-stream" [] non-chunked-stream))
@@ -122,4 +125,5 @@
                :on-message #'on-message-send-handshake)
              wrap-session))
   (web/run (-> #'cdef-handler wrap-params) :path "/cdef")
-  (web/run (-> ws-as-channel wrap-session) :path "/ws"))
+  (web/run (-> ws-as-channel wrap-session) :path "/ws")
+  (web/run (-> dump wrap-session) :path "/dump"))

web/src/immutant/web/internal/servlet.clj

@@ -85,7 +85,7 @@
   (headers [request]            (hdr/headers->map request))
   (body [request]               (.getInputStream request))
   (context [request]            (str (.getContextPath request) (.getServletPath request)))
-  (path-info [request]          (.getPathInfo request))
+  (path-info [request]          (or (.getPathInfo request) "/"))
   (ssl-client-cert [request]    (first (.getAttribute request "javax.servlet.request.X509Certificate")))
   hdr/Headers
   (get-names [request]      (enumeration-seq (.getHeaderNames request)))
@@ -101,6 +101,16 @@
   (set-header [response key value] (.setHeader response key value))
   (add-header [response key value] (.addHeader response key value)))
 
+(defn- ^HttpServletRequest reflect-request
+  [^HandshakeRequest hsr]
+  (-> io.undertow.servlet.websockets.ServletWebSocketHttpExchange
+    (.getDeclaredField "request")
+    (doto (.setAccessible true))
+    (.get (-> io.undertow.websockets.jsr.handshake.ExchangeHandshakeRequest
+            (.getDeclaredField "exchange")
+            (doto (.setAccessible true))
+            (.get hsr)))))
+
 (extend-type javax.websocket.server.HandshakeRequest
   async/WebsocketHandshake
   (headers        [hs] (.getHeaders hs))
@@ -116,15 +126,14 @@
   (server-name        [hs] (-> hs .getRequestURI .getHost))
   (uri                [hs] (-> hs .getRequestURI .toString))
   (query-string       [hs] (.getQueryString hs))
-  (scheme             [hs] (-> hs .getRequestURI .getScheme))
+  (scheme             [hs] (ring/scheme (reflect-request hs)))
   (request-method     [hs] :get)
   (headers            [hs] (-> hs .getHeaders hdr/headers->map))
-  ;; FIXME: should these be the same thing? probably not, inside the container
-  (context            [hs] (-> hs .getRequestURI .getPath))
-  (path-info          [hs] (-> hs .getRequestURI .getPath))
-
+  (context            [hs] (ring/context (reflect-request hs)))
+  (path-info          [hs] (ring/path-info (reflect-request hs)))
+  (remote-addr        [hs] (ring/remote-addr (reflect-request hs)))
+  
   ;; no-ops
-  (remote-addr        [hs])
   (body               [hs])
   (content-type       [hs])
   (content-length     [hs])

web/src/immutant/web/internal/undertow.clj

@@ -147,21 +147,25 @@
   (set-header [headers ^String k ^String v] (throw (Exception. "header map is read-only")))
   (add-header [headers ^String k ^String v] (throw (Exception. "header map is read-only"))))
 
+(defn- ^HttpServerExchange reflect-exchange
+  [^WebSocketHttpExchange wse]
+  (-> io.undertow.websockets.spi.AsyncWebSocketHttpServerExchange
+    (.getDeclaredField "exchange")
+    (doto (.setAccessible true))
+    (.get wse)))
+
 (extend-type io.undertow.websockets.spi.WebSocketHttpExchange
   ring/RingRequest
   (server-port        [x] (-> x .getRequestURI URI. .getPort))
   (server-name        [x] (-> x .getRequestURI URI. .getHost))
-  (remote-addr        [x]
-    (when-let [^WebSocketChannel ws-chan (-> x .getPeerConnections first)]
-      (-> ws-chan .getSourceAddress .getHostName)))
+  (remote-addr        [x] (ring/remote-addr (reflect-exchange x)))
   (uri                [x] (.getRequestURI x))
   (query-string       [x] (.getQueryString x))
-  (scheme             [x] (-> x .getRequestURI URI. .getScheme))
+  (scheme             [x] (-> x .getRequestScheme keyword))
   (request-method     [x] :get)
   (headers            [x] (-> x .getRequestHeaders hdr/headers->map))
-  ;; FIXME: should these be the same thing? maybe so, outside of the container
-  (context            [x] (-> x .getRequestURI URI. .getPath))
-  (path-info          [x] (-> x .getRequestURI URI. .getPath))
+  (context            [x] (ring/context (reflect-exchange x)))
+  (path-info          [x] (ring/path-info (reflect-exchange x)))
 
   ;; no-ops
   (body               [x])

web/test-integration/immutant/web/integ_test.clj

@@ -92,14 +92,16 @@
 
 (deftest request-map-entries
   (get-body (url)) ;; ensure there's something in the session
-  (let [request (decode (get-body (str (url) "request?query=help") :headers {:content-type "text/html; charset=utf-8"}))]
+  (let [request (decode (get-body (str (url) "dump/request?query=help") :headers {:content-type "text/html; charset=utf-8"}))]
     (are [x expected] (= expected (x request))
          :content-type        "text/html; charset=utf-8"
          :character-encoding  "utf-8"
          :remote-addr         "127.0.0.1"
          :server-port         (http-port)
          :content-length      -1
-         :uri                 (str (:context request) "/request")
+         :uri                 (str (if (in-container?) "/integs") "/dump/request")
+         :path-info           "/request"
+         :context             (str (if (in-container?) "/integs") "/dump")
          :server-name         "localhost"
          :query-string        "query=help"
          :scheme              :http
@@ -108,6 +110,20 @@
     (is (map? (:headers request)))
     (is (< 3 (count (:headers request))))))
 
+(deftest upgrade-request-map-entries
+  (let [request (promise)]
+    (with-open [c (http/create-client)
+                s (http/websocket c (str (url "ws") "dump")
+                    :text (fn [_ m] (deliver request (decode m))))]
+      (are [x expected] (= expected (x (deref request 5000 :failure)))
+           :websocket?          true
+           :uri                 (str (if (in-container?) "/integs") "/dump")
+           :context             (str (if (in-container?) "/integs") "/dump")
+           :path-info           "/"
+           :scheme              :http
+           :request-method      :get
+           :remote-addr         "127.0.0.1"))))
+
 (deftest response-charset-should-be-honored
   (doseq [charset ["UTF-8" "Shift_JIS" "ISO-8859-1" "UTF-16" "US-ASCII"]]
     (let [{:keys [headers raw-body]} (get-response (str (url) "charset?charset=" charset))]

web/test/immutant/web/async_test.clj

@@ -107,7 +107,7 @@
         (is (= "Upgrade"   (-> handshake headers (get "Connection") first)))
         (is (= "k"         (-> handshake parameters (get "j") first)))
         (is (= "x=y&j=k"   (-> handshake query-string)))
-        ;; TODO: bug in undertow! (is (= "/?x=y&j=k" (-> handshake uri str)))
+        (is (= "/?x=y&j=k" (-> handshake uri str)))
         (is (false?        (-> handshake (user-in-role? "admin"))))))
     (stop)))