From 1fcec035f04d4645c6ef9eb093a4d3b49963756b Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@riseup.net>
Date: Sun, 28 Apr 2019 09:47:32 +0000
Subject: [PATCH] Do some checks on the host in FedURI parsing

Until now, there were some simple host checks when verifying the HTTP sig,
meant to forbid hosts that are IP addresses, local hosts, and maybe other weird
cases. These checks moved to Network.FedURI, so now FedURIs in general aren't
allowed to have such hosts. The host type is still `Text` though, for now.
---
 src/Network/FedURI.hs    | 10 ++++++++++
 src/Vervis/Foundation.hs |  4 ----
 2 files changed, 10 insertions(+), 4 deletions(-)

diff --git a/src/Network/FedURI.hs b/src/Network/FedURI.hs
index 52a1644..031e651 100644
--- a/src/Network/FedURI.hs
+++ b/src/Network/FedURI.hs
@@ -38,6 +38,7 @@ import Prelude
 import Control.Monad ((<=<))
 import Data.Aeson
 import Data.Bifunctor (bimap, first)
+import Data.Char
 import Data.Hashable
 import Data.Maybe (fromJust)
 import Data.Text (Text)
@@ -53,6 +54,7 @@ import qualified Data.Text as T (pack, unpack, stripPrefix)
 -- * The scheme is HTTPS
 -- * The authority part is present
 -- * The authority part doesn't have userinfo
+-- * The authority host needs to match certain rules
 -- * The authority part doesn't have a port number
 -- * There is no query part
 -- * A fragment part may be present
@@ -96,6 +98,12 @@ parseFedURI t = do
     if p == ""
         then Right ()
         else Left "URI has non-empty port"
+    if any (== '.') h
+        then Right ()
+        else Left "Host doesn't contain periods"
+    if any isAsciiLetter h
+        then Right ()
+        else Left "Host doesn't contain ASCII letters"
     if uriQuery uri == ""
         then Right ()
         else Left "URI query is non-empty"
@@ -104,6 +112,8 @@ parseFedURI t = do
         , furiPath     = T.pack $ uriPath uri
         , furiFragment = T.pack $ uriFragment uri
         }
+    where
+    isAsciiLetter c = isAsciiLower c || isAsciiUpper c
 
 toURI :: FedURI -> URI
 toURI (FedURI h p f) = URI
diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs
index 14b7879..0ed9d0d 100644
--- a/src/Vervis/Foundation.hs
+++ b/src/Vervis/Foundation.hs
@@ -777,10 +777,6 @@ instance YesodHttpSig App where
                 Left e -> throwE $ "keyId in Sig header isn't a valid FedURI: " ++ e
                 Right u -> return u
         checkHost h = do
-            unless (T.any (== '.') h) $
-                throwE "Host doesn't contain periods"
-            unless (T.any isAsciiLetter h) $
-                throwE "Host doesn't contain ASCII letters"
             home <- getsYesod $ appInstanceHost . appSettings
             when (h == home) $
                 throwE "Received HTTP signed request from the instance's host"