From 6c41185fd189de4242749b6dd787099a37270c68 Mon Sep 17 00:00:00 2001
From: Daniel Schadt <kingdread@gmx.de>
Date: Mon, 8 Nov 2021 18:59:47 +0100
Subject: reply 59 on proxy requests

This makes the server more compliant with what is to be expected and
prevents routes from matching when a wrong scheme is given (such as
https://).

It is not perfect yet, as abusing the route matching function for such
an important property is probably not the best. We also want to
implement other request-sanity-checks (such as port numbers being
given), which would also be better done at a different place.

However, we also don't want to prevent Cana from being used to implement
Gemini proxy servers, so a flag in GeminiServer would probably be nice
("extended URI checks").

Yet - on the completely other hand - allowing that much freedom also
means weird interactions (such as a default vhost, certificate issues,
...), so it is unclear how far we want to go.
---
 src/Cana.hs        |  2 +-
 src/Cana/Router.hs | 26 +++++++++++++++++++++++++-
 src/Cana/Server.hs | 16 ++++++++++++++--
 3 files changed, 40 insertions(+), 4 deletions(-)

(limited to 'src')

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   = ""
+  })
-- 
cgit v1.2.3