From e25119f6a4da6605ed555bd2b7a3293c252aca21 Mon Sep 17 00:00:00 2001 From: Daniel Schadt Date: Thu, 8 Jul 2021 20:27:54 +0200 Subject: 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. --- src/Cana.hs | 17 ++++++++++++++--- src/Cana/Server.hs | 44 ++++++++++++++++++++++++++++++++++++++++---- src/Cana/Types.hs | 25 ++++++++++++++++++++++--- src/Cana/Util.hs | 19 +++++++++++++++++++ 4 files changed, 95 insertions(+), 10 deletions(-) create mode 100644 src/Cana/Util.hs (limited to 'src') 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) -- cgit v1.2.3