diff options
| -rw-r--r-- | src/Cana.hs | 2 | ||||
| -rw-r--r-- | src/Cana/Router.hs | 26 | ||||
| -rw-r--r-- | src/Cana/Server.hs | 16 |
3 files changed, 40 insertions, 4 deletions
diff --git a/src/Cana.hs b/src/Cana.hs index 4d5c4d2..7aca4f2 100644 --- a/src/Cana.hs +++ b/src/Cana.hs @@ -185,7 +185,7 @@ findRoute req = do vhosts <- asks serverVHosts let hostName = maybe "" uriRegName . uriAuthority $ requestUri req vhost = findVHost hostName vhosts - routes = maybe [] vhostRoutes vhost + routes = maybe [denyProxyRoute] vhostRoutes vhost return $ snd <$> findIt routes where findIt = find (\(pred, _) -> pred req) diff --git a/src/Cana/Router.hs b/src/Cana/Router.hs index 1454375..757e9c9 100644 --- a/src/Cana/Router.hs +++ b/src/Cana/Router.hs @@ -1,18 +1,42 @@ -- | -- Module : Cana.Router -module Cana.Router where +module Cana.Router + ( -- * Predicate combinators + (&&~) + , (||~) + -- * Predicates + , anyRoute + , geminiScheme + , routeHost + ) where import Cana.Types import Cana.Protocol import Cana.Monad +import Control.Arrow import Network.URI +infixr 3 &&~ +infixr 2 ||~ + +-- | A predicate that matches when both predicates match. +(&&~) :: Predicate -> Predicate -> Predicate +(&&~) a b = uncurry (&&) . (a &&& b) + +-- | A predicate that matches when one of the predicates matches. +(||~) :: Predicate -> Predicate -> Predicate +(||~) a b = uncurry (||) . (a &&& b) + -- | A predicate that always triggers, e.g. for catch-all routes. anyRoute :: Predicate anyRoute = const True +-- | A predicate that matches the @gemini://@ scheme. +geminiScheme :: Predicate +geminiScheme = (== "gemini:") . uriScheme . requestUri + -- | A predicate that matches the given hostname. routeHost :: String -> Predicate routeHost host request = case uriAuthority (requestUri request) of diff --git a/src/Cana/Server.hs b/src/Cana/Server.hs index 130de47..6f9cc50 100644 --- a/src/Cana/Server.hs +++ b/src/Cana/Server.hs @@ -14,12 +14,14 @@ module Cana.Server , loadCredentials , hostMatches , findVHost + , denyProxyRoute ) where import Cana.Protocol import Cana.Types import Cana.Util import Cana.Handlers +import Cana.Router import Control.Monad.Trans.Except import Control.Monad.IO.Class @@ -115,7 +117,7 @@ parseConfig input = case parse input of return VirtualHost { vhostName = UTF8.toString host , vhostCredentials = creds - , vhostRoutes = routes + , vhostRoutes = routes ++ [denyProxyRoute] } loadRoute :: Node -> ExceptT String IO Route @@ -125,7 +127,7 @@ parseConfig input = case parse input of let predicate = (=~ match) . uriPath . requestUri handler <- unwrapMaybe "No handler given for route" (listToMaybe $ children elem) >>= makeHandler - return (predicate, handler) + return (geminiScheme &&~ predicate, handler) makeHandler :: Node -> ExceptT String IO Handler makeHandler elem = case name elem of @@ -185,3 +187,13 @@ hostMatches patt host = matches (prepare patt) (prepare host) -- | Find the correct virtual host based on the hostname. findVHost :: HostName -> [VirtualHost] -> Maybe VirtualHost findVHost hostName = find (flip hostMatches hostName . vhostName) + + +-- | A route that matches non-gemini schemes and replies with +-- 'codeProxyRequestRefused'. +denyProxyRoute :: Route +denyProxyRoute = (not . geminiScheme, const $ return GeminiResponse + { responseStatus = codeProxyRequestRefused + , responseMeta = "You may not proxy through this server" + , responseData = "" + }) |