1 files changed, 14 insertions, 3 deletions
diff --git a/src/Cana.hs b/src/Cana.hs
index 5d80057..bd425ef 100644
--- a/src/Cana.hs
+++ b/src/Cana.hs
@@ -53,6 +53,7 @@ import Cana.Protocol
 import Cana.Router
 
 import Data.List
+import Data.Maybe
 import Control.Monad.IO.Class
 import Control.Concurrent (forkFinally)
 import qualified Control.Exception as E
@@ -79,7 +80,12 @@ runGeminiServer :: Maybe HostName -- ^ Hostname to bind to.
                 -> IO ()
 runGeminiServer hostName serviceName credFile keyFile routes = do
   creds <- loadCredentials credFile keyFile
-  result <- runCana (mkGeminiServer hostName serviceName creds routes) canaServer
+  let vhost = VirtualHost {
+      vhostName        = "*"
+    , vhostCredentials = creds
+    , vhostRoutes      = routes
+    }
+  result <- runCana (mkGeminiServer hostName serviceName creds [vhost]) canaServer
   case result of
     Right _ -> return ()
     Left  s -> fail s
@@ -173,8 +179,13 @@ writeResponse context = TLS.sendData context . renderResponse
 -- | Find the fitting route for the given request.
 findRoute :: GeminiRequest -> Cana (Maybe Handler)
 findRoute req = do
-  routes <- asks serverRoutes
-  return $ snd <$> find (\(pred, _) -> pred req) routes
+  vhosts <- asks serverVHosts
+  let hostName = maybe "" uriRegName . uriAuthority $ requestUri req
+      vhost    = findVHost hostName vhosts
+      routes   = maybe [] vhostRoutes vhost
+  return $ snd <$> findIt routes
+    where
+      findIt = find (\(pred, _) -> pred req)
 
 -- | Run a TCP server.
 --