Expose virtual host settings [IMMUTANT-73]

docs/src/org/initialization.org

@@ -95,6 +95,9 @@
   - =:context-path= - overrides the default web context path that is generated
     based on the deployment name. See [[./web.html#web-context-path][Web - Context Paths]] for more details.
 
+  - =:virtual-host= - allows setting a virtual host for the application. See
+    [[./web.html#web-virtual-host][Web - Virtual Host]] for more details.
+
   A sample deployment descriptor:
 
   #+begin_src clojure

docs/src/org/web.org

@@ -47,8 +47,9 @@
    See [[./deployment.html][Deployment]] for the details of deploying Clojure applications.
 
    You can override the default context path via the =:context-path= key in
-   either in the deployment descriptor or the application's =project.clj=.
-   See [[./initialization.html][Initialization]] for the details on setting configuration values.
+   either in the deployment descriptor or the =:immutant= section of the 
+   application's =project.clj= (see [[./initialization.html][Initialization]] for the details on setting 
+   configuration values).
 
    This context path is considered the *top-level* context path - you have the
    option to bind a handler to a *sub-context* path that will be nested within
@@ -65,6 +66,20 @@
    requests to the handler, and allows you to have multiple webapps within
    a single application.
 
+* Virtual Host
+  :PROPERTIES:
+  :CUSTOM_ID: web-virtual-host
+  :END:
+
+  In addition to segmenting applications by context path, you can also segment
+  by *virtual host*. To specify the virtual host (or hosts) for an application,
+  set the =:virtual-host= key in either in the deployment descriptor or the 
+  =:immutant= section of the application's =project.clj= (see [[./initialization.html][Initialization]] 
+  for the details on setting configuration values). =:virtual-host= must be
+  a string specifying a single host or a vector of strings specifying multiple
+  hosts. Two applications with different virtual hosts can use the same 
+  context path without collision.
+
 * Registering Handlers
 
   To register a Ring handler, you simply call the [[./apidoc/immutant.web-api.html#immutant.web/start][immutant.web/start]], which

integration-tests/src/test/clojure/immutant/integs/vhosts.clj

@@ -0,0 +1,54 @@
+;; Copyright 2008-2012 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 immutant.integs.vhosts
+  (:use fntest.core
+        clojure.test)
+  (:require [clj-http.client :as client]))
+
+(use-fixtures :once 
+              (with-deployments {"vhost-app1"
+                                 '{
+                                   :root "target/apps/ring/basic-ring/"
+                                   :init basic-ring.core/init-web
+                                   :context-path "/basic-ring"
+                                   :virtual-host "integ-app1.torquebox.org"
+                                   }
+                                 "vhost-app2"
+                                 '{
+                                   :root "target/apps/ring/basic-ring/"
+                                   :init basic-ring.core/init-web
+                                   :context-path "/basic-ring"
+                                   :virtual-host ["integ-app2.torquebox.org"
+                                                  "integ-app3.torquebox.org"]
+                                   }}))
+
+(deftest simple "it should work"
+  (let [result (client/get "http://integ-app1.torquebox.org:8080/basic-ring" )]
+    ;;(println "RESPONSE" result)
+    (is (.contains (result :body) "integ-app1.torquebox.org"))
+    (is (not (.contains (result :body) "integ-app2.torquebox.org"))))
+
+  (let [result (client/get "http://integ-app2.torquebox.org:8080/basic-ring" )]
+    ;;(println "RESPONSE" result)
+    (is (.contains (result :body) "integ-app2.torquebox.org"))
+    (is (.contains (result :body) "integ-app3.torquebox.org"))
+    (is (not (.contains (result :body) "integ-app1.torquebox.org")))))
+
+
+
+

modules/core/src/main/java/org/immutant/core/ClojureMetaData.java

@@ -65,26 +65,30 @@ public List getLeinProfiles() {
      */
     public boolean resolveDependencies() {
         if (this.config.containsKey( "resolve-dependencies" )) {
-            return (Boolean)this.config.get( "resolve-dependencies" );
+            return (Boolean)get( "resolve-dependencies" );
         } else {
             return !isArchive();
         }
     }
 
     public String getString(String key) {
-        return (String)this.config.get( key );
+        return (String)get( key );
     }
 
     @SuppressWarnings("unchecked")
     public Map<String, ?> getHash(String key) {
-        return (Map<String, Object>)this.config.get( key );
+        return (Map<String, Object>)get( key );
     }
 
     @SuppressWarnings("rawtypes")
     public List getList(String key) {
-        return (List) this.config.get( key );
+        return (List) get( key );
     }
 
+    public Object get(String key) {
+        return this.config.get( key );
+    }
+
     @SuppressWarnings({ "rawtypes", "unchecked" })
     public void setConfig(Map config) {
         this.config = config;

modules/web/src/main/java/org/immutant/web/ring/RingMetaData.java

@@ -31,9 +31,16 @@ public class RingMetaData extends WebApplicationMetaData {
 
     public static final AttachmentKey<RingMetaData> ATTACHMENT_KEY = AttachmentKey.create(RingMetaData.class);
 
+    @SuppressWarnings({ "unchecked", "rawtypes" })
     public RingMetaData(ClojureMetaData appMetaData) {
         this.appMetaData = appMetaData;
         setStaticPathPrefix( this.appMetaData.getString( "static" ) );
+        final Object host = this.appMetaData.get( "virtual-host" );
+        if (host instanceof List) {
+            addHosts( (List)host );
+        } else {
+            addHost( (String)host );
+        }
     }
 
     @Override

modules/web/src/test/clojure/org/immutant/web/ring/test/RingMetaData.clj

@@ -0,0 +1,43 @@
+;; Copyright 2008-2012 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 org.immutant.web.ring.test.RingMetaData
+  (:use clojure.test
+        midje.sweet)
+  (:import org.immutant.core.ClojureMetaData
+           org.immutant.web.ring.RingMetaData)
+  (:require [clojure.java.io            :as io]
+            [immutant.runtime.bootstrap :as bootstrap]))
+
+(deftest all-tests
+
+  (fact "multiple hosts should come through as a list"
+    (let [descriptor (ClojureMetaData/parse (io/file (io/resource "multi-host-descriptor.clj")))
+          md (RingMetaData. (ClojureMetaData. "app-name" descriptor))]
+      (.getHosts md) => ["ham.biscuit", "gravy.biscuit"]))
+
+  (fact "a single host should come through as a list"
+    (let [descriptor (ClojureMetaData/parse (io/file (io/resource "single-host-descriptor.clj")))
+          md (RingMetaData. (ClojureMetaData. "app-name" descriptor))]
+      (.getHosts md) => ["ham.biscuit"]))
+
+  (fact "a no host should come through as an empty list"
+    (let [descriptor (ClojureMetaData/parse (io/file (io/resource "no-host-descriptor.clj")))
+          md (RingMetaData. (ClojureMetaData. "app-name" descriptor))]
+      (.getHosts md) => [])))
+
+

modules/web/src/test/resources/multi-host-descriptor.clj

@@ -0,0 +1 @@
+{ :virtual-host ["ham.biscuit", "gravy.biscuit"] }

modules/web/src/test/resources/no-host-descriptor.clj

@@ -0,0 +1 @@
+{ }

modules/web/src/test/resources/single-host-descriptor.clj

@@ -0,0 +1 @@
+{ :virtual-host "ham.biscuit" }

support/fntest/src/main/clojure/fntest/core.clj

@@ -1,15 +1,15 @@
 ;; Copyright 2008-2012 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
@@ -29,13 +29,18 @@
      (println "Stopping JBoss")
      (jboss/stop))))
 
-(defn with-deployment
-  "Returns a test fixture for deploying/undeploying an app to a running JBoss"
-  [name descriptor-or-file]
+(defn with-deployments
+  "Returns a test fixture for deploying/undeploying multiple apss to a running JBoss"
+  [descriptor-map]
   (fn [f]
     (try
-      (when (jboss/wait-for-ready? 20) (jboss/deploy name descriptor-or-file))
+      (when (jboss/wait-for-ready? 20)
+        (jboss/deploy descriptor-map))
       (f)
       (finally
-       (jboss/undeploy name)))))
+       (apply jboss/undeploy (keys descriptor-map))))))
 
+(defn with-deployment
+  "Returns a test fixture for deploying/undeploying an app to a running JBoss"
+  [name descriptor-or-file]
+  (with-deployments {name descriptor-or-file}))

support/fntest/src/main/clojure/fntest/jboss.clj

@@ -98,18 +98,24 @@
 
 (defn deploy
   "Create an app deployment descriptor from the content and deploy it"
-  [name content]
-  (let [file (if (= java.io.File (class content)) content (descriptor name content))
-        fname (.getName file)
-        url (str (.toURL file))
-        add (api :operation "add" :address ["deployment" fname] :content [{:url url}])]
-    (when-not (= "success" (add :outcome))
-      (api :operation "remove" :address ["deployment" fname])
-      (api :operation "add" :address ["deployment" fname] :content [{:url url}]))
-    (api :operation "deploy" :address ["deployment" fname])))
+  ([content-map]
+     (doseq [[name content] content-map]
+       (deploy name content)))
+  ([name content]
+      (let [file (if (= java.io.File (class content)) content (descriptor name content))
+            fname (.getName file)
+            url (str (.toURL file))
+            add (api :operation "add" :address ["deployment" fname] :content [{:url url}])]
+        (when-not (= "success" (add :outcome))
+          (api :operation "remove" :address ["deployment" fname])
+          (api :operation "add" :address ["deployment" fname] :content [{:url url}]))
+        (api :operation "deploy" :address ["deployment" fname]))))
 
 (defn undeploy
-  "Undeploy the app named name"
-  [name]
-  (api :operation "remove" :address ["deployment" (deployment-name name)]))
+  "Undeploy the apps deployed under the given names"
+  [& names]
+  (doseq [name names]
+    (api :operation "remove" :address ["deployment" (deployment-name name)])))
+
+