Exposing ability to mount servlets at sub-context-paths [IMMUTANT-253]

We no longer use RingServlet, but either a reified Servlet instance
wrapping a Ring handler or a proxied Servlet that sets the TCCL
appropriately before invoking the servlet's service method.

This is to support the mounting of Pedestal servlets comprised of
multiple "interceptors" rather than a single Ring handler.

modules/core/src/main/clojure/immutant/runtime.clj

@@ -63,11 +63,11 @@ bootstrapping process. Applications shouldn't use anything here."
   []
   (let [project (registry/get :project)]
     (when-let [handler (get-in project [:ring :handler])]
-      (require-and-invoke "immutant.web/start*"
+      (require-and-invoke "immutant.web/start-handler"
                           "/"
                           (util/try-resolve handler)
-                          {:init    (util/try-resolve (get-in project [:ring :init]))
-                           :destroy (util/try-resolve (get-in project [:ring :destroy]))})
+                          :init    (util/try-resolve (get-in project [:ring :init]))
+                          :destroy (util/try-resolve (get-in project [:ring :destroy])))
       (log/info "Initialized" (util/app-name) "from :ring options in project.clj")
       true)))
 

modules/core/src/test/clojure/immutant/runtime_test.clj

@@ -84,7 +84,7 @@
                                   :destroy guestbook.handler/destroy}})
   (try
     (initialize nil nil)
-    (let [[path handler {:keys [init destroy]}]  @a-value]
+    (let [[path handler & {:keys [init destroy]}]  @a-value]
       (is (= "/" path))
       (is (= "war-handler" (handler)))
       (is (= "init"  (init)))

modules/core/src/test/resources/mock-web/src/immutant/web.clj

@@ -1,4 +1,4 @@
 (ns immutant.web)
 
-(defn start* [& args]
+(defn start-handler [& args]
   (reset! immutant.runtime-test/a-value args))

modules/web/src/main/clojure/immutant/web.clj

@@ -19,21 +19,28 @@
   "Associate one or more Ring handlers with your application, mounted
    at unique context paths"
   (:require [clojure.tools.logging  :as log]
-            [immutant.util          :as util]
             [ring.util.codec        :as codec]
-            [ring.util.response     :as response])
-  (:use [immutant.web.internal :exclude [current-servlet-request]])
-  (:use [immutant.web.middleware :only [add-middleware]])
+            [ring.util.response     :as response]
+            [immutant.web.servlet   :as servlet])
+  (:use [immutant.web.internal :only [start* stop*]]
+        [immutant.web.middleware :only [add-middleware]])
   (:import javax.servlet.http.HttpServletRequest))
 
-(declare stop start*)
+(defn start-servlet
+  "Can be used to mount a servlet in lieu of a typical Ring handler"
+  [sub-context-path servlet]
+  (log/info "Registering servlet at sub-context path:" sub-context-path)
+  (start* sub-context-path
+          (servlet/proxy-servlet servlet)
+          {}))
 
-(defn ^HttpServletRequest current-servlet-request
-  "Returns the currently active HttpServletRequest. This will only
-  return a value within an active ring handler. Standard ring handlers
-  should never need to access this value."
-  []
-  immutant.web.internal/current-servlet-request)
+(defn start-handler
+  "Typically not called directly; use start instead"
+  [sub-context-path handler & {:keys [init destroy] :as opts}]
+  (log/info "Registering ring handler at sub-context path:" sub-context-path)
+  (start* sub-context-path
+          (servlet/create-servlet (add-middleware handler opts))
+          opts))
 
 (defmacro start
   "Registers a Ring handler that will be called when requests
@@ -51,53 +58,25 @@
   (let [[path args] (if (even? (count args))
                       [(first args) (next args)]
                       ["/" args])
-        [handler & {:as opts}] args]
+        [handler & opts] args]
     (if (symbol? handler)
-      `(start* ~path (var ~handler) ~opts)
-      `(start* ~path ~handler ~opts))))
-
-(defn ^{:no-doc true} start*
-  [sub-context-path handler {:keys [init destroy] :as opts}]
-  (util/if-in-immutant
-   (let [handler (add-middleware handler opts)
-         sub-context-path (normalize-subcontext-path sub-context-path)
-         servlet-name (servlet-name sub-context-path)]
-     (if-let [existing-info (get-servlet-info servlet-name)]
-       (do
-         (log/debug "Updating ring handler at sub-context path:" sub-context-path)
-         (store-servlet-info!
-          servlet-name
-          (assoc existing-info :handler handler)))
-       (do
-         (log/info "Registering ring handler at sub-context path:" sub-context-path)
-         (store-servlet-info!
-          servlet-name
-          {:wrapper (install-servlet "org.immutant.web.servlet.RingServlet"
-                                     sub-context-path)
-           :sub-context sub-context-path
-           :handler handler
-           :destroy destroy})
-         (util/at-exit #(stop sub-context-path))
-         (and init (init))))
-     nil)
-   (log/warn "web/start called outside of Immutant, ignoring")))
-
+      `(start-handler ~path (var ~handler) ~@opts)
+      `(start-handler ~path ~handler ~@opts))))
 
 (defn stop
-  "Deregisters the Ring handler attached to the given sub-context-path.
+  "Deregisters the Ring handler or servlet mounted at the given sub-context-path.
    If no sub-context-path is given, \"/\" is assumed."
   ([]
      (stop "/"))
   ([sub-context-path]
-     (util/if-in-immutant
-      (let [sub-context-path (normalize-subcontext-path sub-context-path)]
-        (if-let [{:keys [wrapper destroy]} (remove-servlet-info! (servlet-name sub-context-path))]
-          (do
-            (log/info "Deregistering ring handler at sub-context path:" sub-context-path)
-            (remove-servlet sub-context-path wrapper)
-            (and destroy (destroy)))
-          (log/warn "Attempted to deregister ring handler at sub-context path:" sub-context-path ", but none found")))
-      (log/warn "web/stop called outside of Immutant, ignoring"))))
+     (stop* sub-context-path)))
+
+(defn ^HttpServletRequest current-servlet-request
+  "Returns the currently active HttpServletRequest. This will only
+  return a value within an active ring handler. Standard ring handlers
+  should never need to access this value."
+  []
+  immutant.web.internal/current-servlet-request)
 
 (defn wrap-resource
   "Temporary workaround for its non-context-aware namesake from

modules/web/src/main/clojure/immutant/web/internal.clj

@@ -76,20 +76,22 @@
       vh
       [vh])))
 
-(defn install-servlet [servlet-class sub-context-path]
+(defn install-servlet [servlet sub-context-path]
   (let [context (registry/get "web-context")
         name (servlet-name sub-context-path)
         wrapper (.createWrapper context)
         mapper (-> (registry/get "jboss.web")
                    (.getService)
                    (.getMapper))
+        servlet-class (.getName (class servlet))
         complete (promise)]
     (if (and
          (when-context-available
           context
           (doto wrapper
             (.setName name)
             (.setServletClass servlet-class)
+            (.setServlet servlet)
             (.setEnabled true)
             (.setDynamic true)
             (.setAsyncSupported true)
@@ -120,5 +122,31 @@
          (catch Exception _)))))
   nil)
 
+(defn stop*
+  "Deregisters the Ring handler attached to the given sub-context-path."
+  [sub-context-path]
+  (util/if-in-immutant
+   (let [sub-context-path (normalize-subcontext-path sub-context-path)]
+     (if-let [{:keys [wrapper destroy]} (remove-servlet-info! (servlet-name sub-context-path))]
+       (do
+         (log/info "Deregistering ring handler at sub-context path:" sub-context-path)
+         (remove-servlet sub-context-path wrapper)
+         (and destroy (destroy)))
+       (log/warn "Attempted to deregister ring handler at sub-context path:" sub-context-path ", but none found")))
+   (log/warn "web/stop called outside of Immutant, ignoring")))
 
+(defn start*
+  [sub-context-path servlet {:keys [init destroy] :as opts}]
+  (util/if-in-immutant
+   (let [sub-context-path (normalize-subcontext-path sub-context-path)
+         servlet-name (servlet-name sub-context-path)]
+     (when (get-servlet-info servlet-name)
+       (stop* sub-context-path))
+     (store-servlet-info!
+      servlet-name
+      {:wrapper (install-servlet servlet sub-context-path)
+       :destroy destroy})
+     (util/at-exit #(stop* sub-context-path))
+     (and init (init)))
+   (log/warn "web/start called outside of Immutant, ignoring")))
 

modules/web/src/main/clojure/immutant/web/servlet.clj

@@ -0,0 +1,65 @@
+;; Copyright 2008-2013 Red Hat, Inc, and individual contributors.
+;; 
+;; This is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU Lesser General Public License as
+;; published by the Free Software Foundation; either version 2.1 of
+;; the License, or (at your option) any later version.
+;; 
+;; This software is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;; 
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; if not, write to the Free
+;; Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
+;; 02110-1301 USA, or see the FSF site: http://www.fsf.org.
+
+(ns ^{:no-doc true} immutant.web.servlet
+  (:use [immutant.web.internal :only [current-servlet-request]]
+        [immutant.util :only [with-tccl]])
+  (:require [ring.util.servlet :as servlet])
+  (:import javax.servlet.http.HttpServletRequest))
+
+(defn- context [^HttpServletRequest request]
+  (str (.getContextPath request)
+       (.getServletPath request)))
+
+;; we don't use .getPathInfo since it is decoded. See IMMUTANT-195
+(defn- path-info [^HttpServletRequest request]
+  (let [path-info (.substring (.getRequestURI request)
+                              (.length (context request)))]
+    (if (.isEmpty path-info)
+      "/"
+      path-info)))
+
+(defn create-servlet [handler]
+  (reify javax.servlet.Servlet
+    (service [_ request response]
+      (with-tccl
+        (.setCharacterEncoding response "UTF-8")
+        (if-let [response-map (binding [current-servlet-request request]
+                                (handler
+                                 (assoc (servlet/build-request-map request)
+                                   :context (context request)
+                                   :path-info (path-info request))))]
+          (servlet/update-servlet-response response response-map)
+          (throw (NullPointerException. "Handler returned nil.")))))
+    (init [_ _])
+    (destroy [_])))
+
+(deftype ServletProxy [servlet]
+  javax.servlet.Servlet
+  (init [_ config]
+    (with-tccl (.init servlet config)))
+  (service [_ request response]
+    (with-tccl (.service servlet request response)))
+  (destroy [_]
+    (.destroy servlet))
+  (getServletConfig [_]
+    (.getServletConfig servlet))
+  (getServletInfo [_]
+    (.getServletInfo servlet)))
+
+(defn proxy-servlet [servlet]
+  (ServletProxy. servlet))

modules/web/src/main/java/org/immutant/web/as/WebSubsystemAdd.java

@@ -26,7 +26,6 @@
 import java.util.List;
 
 import org.immutant.web.ring.processors.RingApplicationRecognizer;
-import org.immutant.web.ring.processors.RingServletClojureRuntimeInstaller;
 import org.immutant.web.ring.processors.RingWebApplicationInstaller;
 import org.immutant.web.ring.processors.WebContextRegisteringProcessor;
 
@@ -71,7 +70,6 @@ protected void addDeploymentProcessors(final DeploymentProcessorTarget processor
 
         processorTarget.addDeploymentProcessor( WebExtension.SUBSYSTEM_NAME, Phase.DEPENDENCIES, 1, new WebDependenciesProcessor() );
 
-        processorTarget.addDeploymentProcessor( WebExtension.SUBSYSTEM_NAME, Phase.INSTALL, 1, new RingServletClojureRuntimeInstaller() );
         processorTarget.addDeploymentProcessor( WebExtension.SUBSYSTEM_NAME, Phase.INSTALL, 2100, new VirtualHostInstaller() );
         processorTarget.addDeploymentProcessor( WebExtension.SUBSYSTEM_NAME, Phase.INSTALL, Phase.INSTALL_WAR_DEPLOYMENT + 1, new WebContextRegisteringProcessor() );
     }