diff options
| -rw-r--r-- | src/Cana.hs | 17 | ||||
| -rw-r--r-- | src/Cana/Server.hs | 44 | ||||
| -rw-r--r-- | src/Cana/Types.hs | 25 | ||||
| -rw-r--r-- | src/Cana/Util.hs | 19 |
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) |