Add basic support for virtual hosts

We can technically do vhosts with our current infrastructure of route
matching, but they should get some better support. Otherwise, we cannot
use things like SNI (server name indication) to send different
credentials depending on the virtual host.

The way it works now is basically that the server keeps a list of
installed vhosts, each with a domain that it matches and a loaded
certificate. Route matching in a vhost is still done the same old way,
but only routes for the matching vhost are considered in the first
place.

The API for runGeminiServer does not change, so the proper, vhost-using
API, will need a different function and API.

4 files changed, 95 insertions, 10 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.
 --
diff --git a/src/Cana/Server.hs b/src/Cana/Server.hs
index 3cff44a..4171a25 100644
--- a/src/Cana/Server.hs
+++ b/src/Cana/Server.hs
@@ -6,7 +6,10 @@
 module Cana.Server where
 
 import Cana.Types
+import Cana.Util
 
+import Data.List
+import Data.Maybe
 import Data.Default
 import Network.Socket (HostName, ServiceName)
 import qualified Network.TLS as TLS
@@ -16,13 +19,13 @@ import qualified Network.TLS.Extra.Cipher as TE
 --
 -- This ensures that the 'serverParams' are set up sensibly for the Gemini
 -- server to work.
-mkGeminiServer :: Maybe HostName -> ServiceName -> TLS.Credentials -> [Route] -> GeminiServer
-mkGeminiServer hostName port creds routes = GeminiServer
+mkGeminiServer :: Maybe HostName -> ServiceName -> TLS.Credentials -> [VirtualHost] -> GeminiServer
+mkGeminiServer hostName port creds vhosts = GeminiServer
     { serverCredentials = creds
     , serverParams      = params
     , serverHostName    = hostName
     , serverPort        = port
-    , serverRoutes      = routes
+    , serverVHosts      = vhosts
     }
       where
         params = def
@@ -39,5 +42,38 @@ mkGeminiServer hostName port creds routes = GeminiServer
           , TLS.supportedCiphers  = TE.ciphersuite_default
           }
         hooks = def
-          { TLS.onClientCertificate = const $ return TLS.CertificateUsageAccept
+          { TLS.onClientCertificate    = const $ return TLS.CertificateUsageAccept
+          , TLS.onServerNameIndication = return . fromMaybe creds . (findVHostCreds =<<)
           }
+        findVHostCreds = fmap vhostCredentials . (`findVHost` vhosts)
+
+
+-- | Checks whether a given host matches the given pattern.
+--
+-- This supports wildcards in the pattern, but only as proper parts:
+--
+-- >>> hostMatches "gem.ini" "gem.ini"
+-- True
+-- >>> hostMatches "*.gem.ini" "gem.ini"
+-- False
+-- >>> hostMatches "*.gem.ini" "foo.gem.ini"
+-- True
+-- >>> hostMatches "*em.ini" "gem.ini"
+-- False
+hostMatches :: String -- ^ The pattern.
+            -> String -- ^ The string to check.
+            -> Bool
+hostMatches pattern host = matches (prepare pattern) (prepare host)
+  where
+    prepare = reverse . splitList '.'
+    -- Base case
+    matches []     []     = True
+    -- A wildcard matches any non-empty following segments
+    matches ["*"]  (_:_)  = True
+    matches (x:xs) (y:ys) = x == y && matches xs ys
+    matches _      _      = False
+
+
+-- | Find the correct virtual host based on the hostname.
+findVHost :: HostName -> [VirtualHost] -> Maybe VirtualHost
+findVHost hostName = find (flip hostMatches hostName . vhostName)
diff --git a/src/Cana/Types.hs b/src/Cana/Types.hs
index 250fcc1..a271a40 100644
--- a/src/Cana/Types.hs
+++ b/src/Cana/Types.hs
@@ -26,13 +26,13 @@ newtype Cana a = Cana (ReaderT GeminiServer (ExceptT String IO) a) deriving (Mon
 -- Note that the server certificate is saved here, so any function that has
 -- access to this can also read the private key.
 data GeminiServer = GeminiServer
-    { serverCredentials :: TLS.Credentials -- ^ The server credentials.
-    , serverParams      :: TLS.ServerParams -- ^ The server TLS parameters.
+    { serverCredentials :: TLS.Credentials -- ^ The (default) server credentials.
+    , serverParams      :: TLS.ServerParams -- ^ The (default) server TLS parameters.
     , serverHostName    :: Maybe HostName -- ^ The 'HostName' that the server
                                           -- should bind to.
     , serverPort        :: String -- ^ The port ('ServiceName') that the server
                                   -- should listen on.
-    , serverRoutes      :: [Route] -- ^ The routes that the server handles.
+    , serverVHosts      :: [VirtualHost] -- ^ The virtual hosts on this server.
     }
 
 -- | A predicate is a function that defines whether a route should match.
@@ -41,3 +41,22 @@ type Predicate = GeminiRequest -> Bool
 type Handler   = GeminiRequest -> Cana GeminiResponse
 -- | A route is a combination of a 'Predicate' and a 'Handler'
 type Route     = (Predicate, Handler)
+
+-- | A virtual host.
+--
+-- The concept of virtual hosts allows a single "Cana" server to handle
+-- multiple gemini sites, that for a client appear to be hosted on different
+-- servers.
+--
+-- This requires the client to send a full, absolute URI (which "Cana" expects
+-- anyway), and uses TLS SNI to choose the right certificate.
+data VirtualHost = VirtualHost
+    { vhostName        :: HostName -- ^ The host name of the virtual server. May
+        -- contain a wildcard (@*@) at the beginning to match all subdomains.
+    , vhostCredentials :: TLS.Credentials -- ^ The vhost-specific TLS
+        -- credentials.
+    , vhostRoutes      :: [Route] -- ^ Routes for this vhost.
+        --
+        -- Note that you can add any routes, but the vhost will already do the
+        -- host-based pre-filtering.
+    }
diff --git a/src/Cana/Util.hs b/src/Cana/Util.hs
new file mode 100644
index 0000000..cd97ace
--- /dev/null
+++ b/src/Cana/Util.hs
@@ -0,0 +1,19 @@
+-- |
+-- Module     : Cana.Util
+--
+-- Various small utility functions.
+
+module Cana.Util
+    ( splitList
+    ) where
+
+-- | Split a list on the given element, useful for 'String's.
+--
+-- >>> splitList '.' "foo.bar"
+-- ["foo","bar"]
+splitList :: Eq a => a -> [a] -> [[a]]
+splitList d = uncurry (:) . foldr step ([], [])
+  where
+    step c (w, s)
+      | c == d    = ([], w:s)
+      | otherwise = (c:w, s)