Add required-base-host-header configuration option

This facilitates hosting behind a reverse proxy.

Author: ysangkok

exes/Main.hs

@@ -38,7 +38,7 @@ import System.Directory
 import System.FilePath
          ( (</>), (<.>) )
 import Network.URI
-         ( URI(..), parseAbsoluteURI )
+         ( URI(..), URIAuth(..), parseAbsoluteURI )
 import Distribution.Simple.Command
 import Distribution.Simple.Setup
          ( Flag(..), fromFlag, fromFlagOrDefault, flagToList, flagToMaybe )
@@ -198,6 +198,7 @@ data RunFlags = RunFlags {
     flagRunIP              :: Flag String,
     flagRunHostURI         :: Flag String,
     flagRunUserContentURI  :: Flag String,
+    flagRunRequiredBaseHostHeader :: Flag String,
     flagRunStateDir        :: Flag FilePath,
     flagRunStaticDir       :: Flag FilePath,
     flagRunTmpDir          :: Flag FilePath,
@@ -217,6 +218,7 @@ defaultRunFlags = RunFlags {
     flagRunIP              = NoFlag,
     flagRunHostURI         = NoFlag,
     flagRunUserContentURI  = NoFlag,
+    flagRunRequiredBaseHostHeader = NoFlag,
     flagRunStateDir        = NoFlag,
     flagRunStaticDir       = NoFlag,
     flagRunTmpDir          = NoFlag,
@@ -266,10 +268,14 @@ runCommand =
           "Server's public base URI (defaults to machine name)"
           flagRunHostURI (\v flags -> flags { flagRunHostURI = v })
           (reqArgFlag "NAME")
-      , option [] ["user-content-host"]
-          "Server's public user content host name (for untrusted content, defeating XSS style attacks)"
+      , option [] ["user-content-uri"]
+          "Server's public user content base URI (for untrusted content, defeating XSS style attacks)"
           flagRunUserContentURI (\v flags -> flags { flagRunUserContentURI = v })
           (reqArgFlag "NAME")
+      , option [] ["required-base-host-header"]
+          "Required host header value for incoming requests (potentially internal, e.g. if behind reverse proxy). Base means that it is _not_ for the user-content domain."
+          flagRunRequiredBaseHostHeader (\v flags -> flags { flagRunRequiredBaseHostHeader = v })
+          (reqArgFlag "NAME")
       , optionStateDir
           flagRunStateDir (\v flags -> flags { flagRunStateDir = v })
       , optionStaticDir
@@ -313,7 +319,8 @@ runAction opts = do
     port       <- checkPortOpt    defaults (flagToMaybe (flagRunPort       opts))
     ip         <- checkIPOpt      defaults (flagToMaybe (flagRunIP         opts))
     hosturi    <- checkHostURI    defaults (flagToMaybe (flagRunHostURI    opts)) port
-    usercontenthost <- checkUserContentHost defaults (flagToMaybe (flagRunUserContentURI opts))
+    usercontenturi <- checkUserContentURI defaults (flagToMaybe (flagRunUserContentURI opts))
+    requiredbasehostheader <- checkRequiredBaseHostHeader defaults (flagToMaybe (flagRunRequiredBaseHostHeader opts))
     cacheDelay <- checkCacheDelay defaults (flagToMaybe (flagRunCacheDelay opts))
     let stateDir  = fromFlagOrDefault (confStateDir  defaults) (flagRunStateDir  opts)
         staticDir = fromFlagOrDefault (confStaticDir defaults) (flagRunStaticDir opts)
@@ -324,7 +331,8 @@ runAction opts = do
                     }
         config    = defaults {
                         confHostUri    = hosturi,
-                        confUserContentHost = usercontenthost,
+                        confUserContentUri = usercontenturi,
+                        confRequiredBaseHostHeader = requiredbasehostheader,
                         confListenOn   = listenOn,
                         confStateDir   = stateDir,
                         confStaticDir  = staticDir,
@@ -378,23 +386,37 @@ runAction opts = do
                -> return n
       _        -> fail $ "bad port number " ++ show str
 
-    checkHostURI defaults Nothing _ = fail "You must provide the --base-uri= flag"
-    checkHostURI _        (Just str) _ = case parseAbsoluteURI str of
+    checkHostURI defaults Nothing port = do
+      let guessURI       = confHostUri defaults
+          Just authority = uriAuthority guessURI
+          portStr | port == 80 = ""
+                  | otherwise  = ':' : show port
+          guessURI' = guessURI { uriAuthority = Just authority { uriPort = portStr } }
+      lognotice verbosity $ "Guessing public URI as " ++ show guessURI'
+                        ++ "\n(you can override with the --base-uri= flag)"
+      return guessURI'
+
+    checkHostURI _        (Just str) _ = validateURI str
+
+    validateURI str = case parseAbsoluteURI str of
       Nothing -> fail $ "Cannot parse as a URI: " ++ str ++ "\n"
                      ++ "Make sure you include the http:// part"
       Just uri
         | uriScheme uri `notElem` ["http:", "https:"] ->
           fail $ "Sorry, the server assumes it will be served (or proxied) "
               ++ " via http or https, so cannot use uri scheme " ++ uriScheme uri
         | isNothing (uriAuthority uri) ->
-          fail "The base-uri has to include the full host name"
+          fail "The base-uri and the user-content-uri have to include full host names"
         | uriPath uri `notElem` ["", "/"] ->
-          fail $ "Sorry, the server assumes the base-uri to be at the root of "
-              ++ " the domain, so cannot use " ++ uriPath uri
+          fail $ "Sorry, the server assumes base-uri and user-content-uri to be at the root of "
+              ++ " their domains, so cannot use " ++ uriPath uri
         | otherwise -> return uri { uriPath = "" }
 
-    checkUserContentHost _ Nothing    = fail "You must provide the --user-content-host= flag"
-    checkUserContentHost _ (Just str) = pure str
+    checkUserContentURI _ Nothing    = fail "You must provide the --user-content-uri= flag"
+    checkUserContentURI _ (Just str) = validateURI str
+
+    checkRequiredBaseHostHeader _ Nothing    = fail "You must provide the --required-base-host-header= flag. It's typically the host part of the base-uri."
+    checkRequiredBaseHostHeader _ (Just str) = pure str
 
     checkIPOpt defaults Nothing    = return (loIP (confListenOn defaults))
     checkIPOpt _        (Just str) =

src/Distribution/Server.hs

@@ -68,7 +68,8 @@ data ListenOn = ListenOn {
 data ServerConfig = ServerConfig {
   confVerbosity :: Verbosity,
   confHostUri   :: URI,
-  confUserContentHost :: String,
+  confUserContentUri :: URI,
+  confRequiredBaseHostHeader :: String,
   confListenOn  :: ListenOn,
   confStateDir  :: FilePath,
   confStaticDir :: FilePath,
@@ -97,7 +98,8 @@ defaultServerConfig = do
                       uriScheme    = "http:",
                       uriAuthority = Just (URIAuth "" hostName (':' : show portnum))
                     },
-    confUserContentHost = "",
+    confUserContentUri = nullURI, -- This is a required argument, so the default doesn't matter
+    confRequiredBaseHostHeader = "", -- This is a required argument, so the default doesn't matter
     confListenOn  = ListenOn {
                         loPortNum = 8080,
                         loIP = "127.0.0.1"
@@ -124,7 +126,7 @@ hasSavedState :: ServerConfig -> IO Bool
 hasSavedState = doesDirectoryExist . confDbStateDir
 
 mkServerEnv :: ServerConfig -> IO ServerEnv
-mkServerEnv config@(ServerConfig verbosity hostURI userContentHost _
+mkServerEnv config@(ServerConfig verbosity hostURI userContentURI requiredBaseHostHeader _
                                     stateDir _ tmpDir
                                     cacheDelay liveTemplates) = do
     createDirectoryIfMissing False stateDir
@@ -149,7 +151,8 @@ mkServerEnv config@(ServerConfig verbosity hostURI userContentHost _
             serverTmpDir        = tmpDir,
             serverCacheDelay    = cacheDelay * 1000000, --microseconds
             serverBaseURI       = hostURI,
-            serverUserContentHost = userContentHost,
+            serverUserContentBaseURI = userContentURI,
+            serverRequiredBaseHostHeader = requiredBaseHostHeader,
             serverVerbosity     = verbosity
          }
     return env

src/Distribution/Server/Framework/Auth.hs

@@ -30,6 +30,7 @@ module Distribution.Server.Framework.Auth (
     authErrorResponse,
   ) where
 
+import qualified Data.Text as T
 import Distribution.Server.Users.Types (UserId, UserName(..), UserAuth(..), UserInfo)
 import qualified Distribution.Server.Users.Types as Users
 import qualified Distribution.Server.Users.Users as Users
@@ -39,7 +40,7 @@ import Distribution.Server.Framework.AuthCrypt
 import Distribution.Server.Framework.AuthTypes
 import Distribution.Server.Framework.Error
 import Distribution.Server.Framework.HtmlFormWrapper (rqRealMethod)
-import Distribution.Server.Framework.ServerEnv (ServerEnv, isRegularHost)
+import Distribution.Server.Framework.ServerEnv (ServerEnv(ServerEnv, serverRequiredBaseHostHeader), getHost)
 
 import Happstack.Server
 
@@ -103,10 +104,19 @@ guardAuthenticated realm users env = do
       Right info    -> return info
 
 checkAuthenticated :: ServerMonad m => RealmName -> Users.Users -> ServerEnv -> m (Either AuthError (UserId, UserInfo))
-checkAuthenticated realm users env = do
-    mbHostMismatch <- isRegularHost env
-    case mbHostMismatch of
-       Just (actualHost, oughtToBeHost) -> pure (Left BadHost { actualHost , oughtToBeHost })
+checkAuthenticated realm users ServerEnv { serverRequiredBaseHostHeader } = do
+    mbHost <- getHost
+    case mbHost of
+       Just hostHeaderValue ->
+         if hostHeaderValue /= T.encodeUtf8 (T.pack serverRequiredBaseHostHeader)
+            then pure $ Left BadHost
+              { actualHost=Just hostHeaderValue
+              , oughtToBeHost=serverRequiredBaseHostHeader
+              }
+            else pure $ Left BadHost
+              { actualHost=Nothing
+              , oughtToBeHost=serverRequiredBaseHostHeader
+              }
        Nothing -> do
          req <- askRq
          return $ case getHeaderAuth req of
@@ -430,7 +440,7 @@ data AuthError = NoAuthError
                | UserStatusError       UserId UserInfo
                | PasswordMismatchError UserId UserInfo
                | BadApiKeyError
-               | BadHost { actualHost :: BS.ByteString, oughtToBeHost :: String }
+               | BadHost { actualHost :: Maybe BS.ByteString, oughtToBeHost :: String }
   deriving Show
 
 authErrorResponse :: MonadIO m => RealmName -> AuthError -> m ErrorResponse

src/Distribution/Server/Framework/ServerEnv.hs

@@ -11,7 +11,7 @@ import qualified Data.ByteString as BS
 import qualified Data.Text as T
 import qualified Network.URI as URI
 import Data.List (find)
-import Data.Text.Encoding (decodeASCII', encodeUtf8)
+import Data.Text.Encoding (encodeUtf8)
 import Happstack.Server (ServerMonad(askRq))
 import Happstack.Server.Response (seeOther, toResponse)
 import Happstack.Server.Types (HeaderPair(..), Response, rqHeaders, rqQuery, rqUri)
@@ -58,7 +58,9 @@ data ServerEnv = ServerEnv {
     -- current server (e.g. as required in RSS feeds).
     serverBaseURI   :: URI.URI,
 
-    serverUserContentHost :: String,
+    serverUserContentBaseURI :: URI.URI,
+    -- | This might be an internal host name, used internally behind a load balancer
+    serverRequiredBaseHostHeader :: String,
 
     -- | A tunable parameter for cache policy. Setting this parameter high
     -- during bulk imports can very significantly improve performance. During
@@ -74,55 +76,26 @@ data ServerEnv = ServerEnv {
     serverVerbosity  :: Verbosity
 }
 
-getHostAndBaseAuth :: ServerMonad m => ServerEnv -> m (Maybe (BS.ByteString, URI.URIAuth))
-getHostAndBaseAuth ServerEnv {serverBaseURI} = do
+getHost :: ServerMonad m => m (Maybe BS.ByteString)
+getHost = do
   rq <- askRq
-  let
-    mbHost :: Maybe BS.ByteString
-    mbHost =
-      case find ((== encodeUtf8 (T.pack "host")) . hName) $ rqHeaders rq of
-        Just hostHeaderPair | [oneValue] <- hValue hostHeaderPair ->
-          -- If there is a colon in the host header, remove it.
-          -- We require the regName of user-content and base to differ.
-          -- 58 is ASCII for colon
-          let (beforeColon, _colonAndAfter) = BS.break (== 58) oneValue
-           in Just beforeColon
-        _ -> Nothing
-    mbBaseAuth = URI.uriAuthority serverBaseURI
-  case (,) <$> mbHost <*> mbBaseAuth of
-    Nothing -> pure Nothing
-    Just (hostHeaderValue, baseAuth) -> pure $ Just (hostHeaderValue, baseAuth)
+  pure $
+    case find ((== encodeUtf8 (T.pack "host")) . hName) $ rqHeaders rq of
+      Just hostHeaderPair | [oneValue] <- hValue hostHeaderPair -> Just oneValue
+      _ -> Nothing
 
 requireUserContent :: ServerEnv -> Response -> ServerPartE Response
-requireUserContent env@ServerEnv {serverBaseURI, serverUserContentHost} action = do
-  Just (hostHeaderValue, baseAuth) <- getHostAndBaseAuth env
+requireUserContent ServerEnv {serverUserContentBaseURI, serverRequiredBaseHostHeader} action = do
+  Just hostHeaderValue <- getHost
   rq <- askRq
-  if hostHeaderValue == encodeUtf8 (T.pack $ URI.uriRegName baseAuth)
+  if hostHeaderValue == encodeUtf8 (T.pack serverRequiredBaseHostHeader)
      then
       let
-        uri = URI.URI
-          { URI.uriScheme = URI.uriScheme serverBaseURI
-          , URI.uriAuthority = Just URI.URIAuth { URI.uriUserInfo = "", URI.uriRegName = serverUserContentHost, URI.uriPort = "" }
-          , URI.uriPath = rqUri rq
+        uri = serverUserContentBaseURI
+          { URI.uriPath = rqUri rq
           , URI.uriQuery = rqQuery rq
-          , URI.uriFragment = ""
           }
       in
        seeOther (show uri) (toResponse ())
      else
-       if hostHeaderValue /= encodeUtf8 (T.pack serverUserContentHost)
-          then
-            fail $
-              "Host name (" <> maybe "N/A" T.unpack (decodeASCII' hostHeaderValue) <> ")" <>
-              " matched neither user content host (" <> serverUserContentHost <> ")" <>
-              " nor base host (" <> URI.uriRegName baseAuth <> ")"
-          else pure action
-
--- | Returns Just when the host isn't matching the regular host
-isRegularHost :: ServerMonad m => ServerEnv -> m (Maybe (BS.ByteString, String))
-isRegularHost env = do
-  mbPair <- getHostAndBaseAuth env
-  case mbPair of
-    Just (hostHeaderValue, baseAuth) | hostHeaderValue /= encodeUtf8 (T.pack $ URI.uriRegName baseAuth) ->
-      pure $ Just (hostHeaderValue, URI.uriRegName baseAuth)
-    _ -> pure Nothing
+       pure action