Merge pull request #1379 from haskell/user-content-host-v2

gbaz · web-flow · commit cf59027a6ce1 · 2025-04-08T20:28:37.000-04:00
User content host v2
diff --git a/exes/Main.hs b/exes/Main.hs
@@ -197,6 +197,8 @@ data RunFlags = RunFlags {
     flagRunPort            :: Flag String,
     flagRunIP              :: Flag String,
     flagRunHostURI         :: Flag String,
+    flagRunUserContentURI  :: Flag String,
+    flagRunRequiredBaseHostHeader :: Flag String,
     flagRunStateDir        :: Flag FilePath,
     flagRunStaticDir       :: Flag FilePath,
     flagRunTmpDir          :: Flag FilePath,
@@ -215,6 +217,8 @@ defaultRunFlags = RunFlags {
     flagRunPort            = NoFlag,
     flagRunIP              = NoFlag,
     flagRunHostURI         = NoFlag,
+    flagRunUserContentURI  = NoFlag,
+    flagRunRequiredBaseHostHeader = NoFlag,
     flagRunStateDir        = NoFlag,
     flagRunStaticDir       = NoFlag,
     flagRunTmpDir          = NoFlag,
@@ -264,6 +268,14 @@ runCommand =
           "Server's public base URI (defaults to machine name)"
           flagRunHostURI (\v flags -> flags { flagRunHostURI = v })
           (reqArgFlag "NAME")
+      , 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
@@ -307,6 +319,8 @@ runAction opts = do
     port       <- checkPortOpt    defaults (flagToMaybe (flagRunPort       opts))
     ip         <- checkIPOpt      defaults (flagToMaybe (flagRunIP         opts))
     hosturi    <- checkHostURI    defaults (flagToMaybe (flagRunHostURI    opts)) port
+    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)
@@ -317,6 +331,8 @@ runAction opts = do
                     }
         config    = defaults {
                         confHostUri    = hosturi,
+                        confUserContentUri = usercontenturi,
+                        confRequiredBaseHostHeader = requiredbasehostheader,
                         confListenOn   = listenOn,
                         confStateDir   = stateDir,
                         confStaticDir  = staticDir,
@@ -380,20 +396,28 @@ runAction opts = do
                         ++ "\n(you can override with the --base-uri= flag)"
       return guessURI'
 
-    checkHostURI _        (Just str) _ = case parseAbsoluteURI str of
+    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 = "" }
 
+    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) =
       let pQuad = do ds <- Parse.many1 Parse.digit
diff --git a/src/Distribution/Server.hs b/src/Distribution/Server.hs
@@ -68,6 +68,8 @@ data ListenOn = ListenOn {
 data ServerConfig = ServerConfig {
   confVerbosity :: Verbosity,
   confHostUri   :: URI,
+  confUserContentUri :: URI,
+  confRequiredBaseHostHeader :: String,
   confListenOn  :: ListenOn,
   confStateDir  :: FilePath,
   confStaticDir :: FilePath,
@@ -96,6 +98,8 @@ defaultServerConfig = do
                       uriScheme    = "http:",
                       uriAuthority = Just (URIAuth "" hostName (':' : show portnum))
                     },
+    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"
@@ -122,7 +126,7 @@ hasSavedState :: ServerConfig -> IO Bool
 hasSavedState = doesDirectoryExist . confDbStateDir
 
 mkServerEnv :: ServerConfig -> IO ServerEnv
-mkServerEnv config@(ServerConfig verbosity hostURI _
+mkServerEnv config@(ServerConfig verbosity hostURI userContentURI requiredBaseHostHeader _
                                     stateDir _ tmpDir
                                     cacheDelay liveTemplates) = do
     createDirectoryIfMissing False stateDir
@@ -147,6 +151,8 @@ mkServerEnv config@(ServerConfig verbosity hostURI _
             serverTmpDir        = tmpDir,
             serverCacheDelay    = cacheDelay * 1000000, --microseconds
             serverBaseURI       = hostURI,
+            serverUserContentBaseURI = userContentURI,
+            serverRequiredBaseHostHeader = requiredBaseHostHeader,
             serverVerbosity     = verbosity
          }
     return env
diff --git a/src/Distribution/Server/Features/Documentation.hs b/src/Distribution/Server/Features/Documentation.hs
@@ -7,6 +7,7 @@ module Distribution.Server.Features.Documentation (
     initDocumentationFeature
   ) where
 
+import Distribution.Server.Features.Security.SHA256       (sha256)
 import Distribution.Server.Framework
 
 import Distribution.Server.Features.Documentation.State
@@ -43,7 +44,8 @@ import Data.Function (fix)
 
 import Data.Aeson (toJSON)
 import Data.Maybe
-import Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime)
+import Data.Time.Calendar (fromGregorian)
+import Data.Time.Clock (NominalDiffTime, UTCTime(..), diffUTCTime, getCurrentTime)
 import System.Directory (getModificationTime)
 import Control.Applicative
 import Distribution.Server.Features.PreferredVersions
@@ -154,7 +156,7 @@ documentationFeature :: String
                      -> Hook PackageId ()
                      -> DocumentationFeature
 documentationFeature name
-                     ServerEnv{serverBlobStore = store, serverBaseURI}
+                     env@ServerEnv{serverBlobStore = store, serverBaseURI}
                      CoreResource{
                          packageInPath
                        , guardValidPackageId
@@ -291,11 +293,29 @@ documentationFeature name
             etag    = BlobStorage.blobETag blob
         -- if given a directory, the default page is index.html
         -- the root directory within the tarball is e.g. foo-1.0-docs/
+        mtime <- liftIO $ getModificationTime tarball
         age <- liftIO $ getFileAge tarball
         let maxAge = documentationCacheTime age
-        ServerTarball.serveTarball (display pkgid ++ " documentation")
-                                   [{-no index-}] (display pkgid ++ "-docs")
-                                   tarball index [Public, maxAge] etag (Just rewriteDocs)
+        tarServe <-
+          ServerTarball.serveTarball (display pkgid ++ " documentation")
+                                     [{-no index-}] (display pkgid ++ "-docs")
+                                     tarball index [Public, maxAge] etag (Just rewriteDocs)
+        case tarServe of
+          ServerTarball.TarDir response -> pure response
+          ServerTarball.TarFile fileContent response -> do
+            let
+              digest = show $ sha256 fileContent
+              -- Because JSON files cannot execute code or affect layout, we don't need to verify anything else
+              isDocIndex =
+                case dpath of
+                  ("..","doc-index.json") : _ -> True
+                  _ -> False
+            if mtime < UTCTime (fromGregorian 2025 2 1) 0
+               || isDocIndex
+               || digest == "548d676b3e5a52cbfef06d7424ec065c1f34c230407f9f5dc002c27a9666bec4" -- quick-jump.min.js
+               || digest == "6bd159f6d7b1cfef1bd190f1f5eadcd15d35c6c567330d7465c3c35d5195bc6f" -- quick-jump.css
+               then pure response
+               else requireUserContent env response
 
     rewriteDocs :: BSL.ByteString -> BSL.ByteString
     rewriteDocs dochtml = case BSL.breakFindAfter (BS.pack "<head>") dochtml of
diff --git a/src/Distribution/Server/Features/PackageCandidates.hs b/src/Distribution/Server/Features/PackageCandidates.hs
@@ -609,7 +609,7 @@ candidatesFeature ServerEnv{serverBlobStore = store}
         Left err ->
           errNotFound "Could not serve package contents" [MText err]
         Right (fp, etag, index) ->
-          serveTarball (display (packageId pkg) ++ " candidate source tarball")
+          tarServeResponse <$> serveTarball (display (packageId pkg) ++ " candidate source tarball")
                        ["index.html"] (display (packageId pkg)) fp index
                        [Public, maxAgeMinutes 5] etag Nothing
 
diff --git a/src/Distribution/Server/Features/PackageContents.hs b/src/Distribution/Server/Features/PackageContents.hs
@@ -206,7 +206,7 @@ packageContentsFeature CoreFeature{ coreResource = CoreResource{
         Left err ->
           errNotFound "Could not serve package contents" [MText err]
         Right (fp, etag, index) ->
-          serveTarball (display (packageId pkg) ++ " source tarball")
+          tarServeResponse <$> serveTarball (display (packageId pkg) ++ " source tarball")
                        [] (display (packageId pkg)) fp index
                        [Public, maxAgeDays 30] etag Nothing
 
diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs
@@ -441,7 +441,7 @@ initUserNotifyFeature :: ServerEnv
                           -> ReverseFeature
                           -> VouchFeature
                           -> IO UserNotifyFeature)
-initUserNotifyFeature env@ServerEnv{ serverStateDir, serverTemplatesDir,
+initUserNotifyFeature ServerEnv{ serverStateDir, serverTemplatesDir,
                                      serverTemplatesMode } = do
     -- Canonical state
     notifyState <- notifyStateComponent serverStateDir
@@ -452,7 +452,7 @@ initUserNotifyFeature env@ServerEnv{ serverStateDir, serverTemplatesDir,
                    [ "user-notify-form.html", "endorsements-complete.txt" ]
 
     return $ \users core uploadfeature adminlog userdetails reports tags revers vouch -> do
-      let feature = userNotifyFeature env
+      let feature = userNotifyFeature
                       users core uploadfeature adminlog userdetails reports tags
                       revers vouch notifyState templates
       return feature
@@ -576,8 +576,7 @@ pkgInfoToPkgId :: PkgInfo -> PackageIdentifier
 pkgInfoToPkgId pkgInfo =
   PackageIdentifier (packageName pkgInfo) (packageVersion pkgInfo)
 
-userNotifyFeature :: ServerEnv
-                  -> UserFeature
+userNotifyFeature :: UserFeature
                   -> CoreFeature
                   -> UploadFeature
                   -> AdminLogFeature
@@ -589,8 +588,7 @@ userNotifyFeature :: ServerEnv
                   -> StateComponent AcidState NotifyData
                   -> Templates
                   -> UserNotifyFeature
-userNotifyFeature serverEnv@ServerEnv{serverCron}
-                  UserFeature{..}
+userNotifyFeature UserFeature{..}
                   CoreFeature{..}
                   UploadFeature{..}
                   AdminLogFeature{..}
@@ -603,6 +601,7 @@ userNotifyFeature serverEnv@ServerEnv{serverCron}
   = UserNotifyFeature {..}
 
   where
+    ServerEnv {serverCron} = userFeatureServerEnv
     userNotifyFeatureInterface = (emptyHackageFeature "user-notify") {
         featureDesc      = "Notifications to users on metadata updates."
       , featureResources = [userNotifyResource] -- TODO we can add json features here for updating prefs
@@ -717,7 +716,7 @@ userNotifyFeature serverEnv@ServerEnv{serverCron}
         vouchNotifications <- fmap (, NotifyVouchingCompleted) <$> drainQueuedNotifications
 
         emails <-
-          getNotificationEmails serverEnv userDetailsFeature users templates $
+          getNotificationEmails userFeatureServerEnv userDetailsFeature users templates $
             concat
               [ revisionUploadNotifications
               , groupActionNotifications
diff --git a/src/Distribution/Server/Features/Users.hs b/src/Distribution/Server/Features/Users.hs
@@ -144,7 +144,8 @@ data UserFeature = UserFeature {
     -- | For a given user, return all of the URIs for groups they are in.
     getGroupIndex       :: forall m. (Functor m, MonadIO m) => UserId -> m [String],
     -- | For a given URI, get a GroupDescription for it, if one can be found.
-    getIndexDesc        :: forall m. MonadIO m => String -> m GroupDescription
+    getIndexDesc        :: forall m. MonadIO m => String -> m GroupDescription,
+    userFeatureServerEnv :: ServerEnv
 }
 
 instance IsHackageFeature UserFeature where
@@ -227,7 +228,7 @@ deriveJSON (compatAesonOptionsDropPrefix "ui_")  ''UserGroupResource
 
 -- TODO: add renaming
 initUserFeature :: ServerEnv -> IO (IO UserFeature)
-initUserFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMode} = do
+initUserFeature serverEnv@ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMode} = do
   -- Canonical state
   usersState  <- usersStateComponent  serverStateDir
   adminsState <- adminsStateComponent serverStateDir
@@ -261,6 +262,7 @@ initUserFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMod
                             groupIndex
                             userAdded authFailHook groupChangedHook
                             adminG adminR
+                            serverEnv
 
         (adminG, adminR) <- groupResourceAt "/users/admins/" adminGroupDesc
 
@@ -301,10 +303,11 @@ userFeature :: Templates
             -> Hook (GroupDescription, Bool, UserId, UserId, String) ()
             -> UserGroup
             -> GroupResource
+            -> ServerEnv
             -> (UserFeature, UserGroup)
 userFeature templates usersState adminsState
              groupIndex userAdded authFailHook groupChangedHook
-             adminGroup adminResource
+             adminGroup adminResource userFeatureServerEnv
   = (UserFeature {..}, adminGroupDesc)
   where
     userFeatureInterface = (emptyHackageFeature "users") {
@@ -484,7 +487,7 @@ userFeature templates usersState adminsState
     -- See note about "authn" cookie above
     guardAuthenticatedWithErrHook :: Users.Users -> ServerPartE UserId
     guardAuthenticatedWithErrHook users = do
-        (uid,_) <- Auth.checkAuthenticated realm users
+        (uid,_) <- Auth.checkAuthenticated realm users userFeatureServerEnv
                    >>= either handleAuthError return
         addCookie Session (mkCookie "authn" "1")
         -- Set-Cookie:authn="1";Path=/;Version="1"
@@ -493,6 +496,8 @@ userFeature templates usersState adminsState
         realm = Auth.hackageRealm --TODO: should be configurable
 
         handleAuthError :: Auth.AuthError -> ServerPartE a
+        handleAuthError Auth.BadHost { actualHost, oughtToBeHost } =
+          errForbidden "Bad Host" [MText $ "Authenticated resources can only be accessed using the regular server host name " <> oughtToBeHost <> ", but was provided host " <> show actualHost]
         handleAuthError err = do
           defaultResponse  <- Auth.authErrorResponse realm err
           overrideResponse <- msum <$> runHook authFailHook err
@@ -513,7 +518,7 @@ userFeature templates usersState adminsState
           _        -> pure ()
 
         users <- queryGetUserDb
-        either (const Nothing) Just `fmap` Auth.checkAuthenticated Auth.hackageRealm users
+        either (const Nothing) Just `fmap` Auth.checkAuthenticated Auth.hackageRealm users userFeatureServerEnv
 
     -- | Resources representing the collection of known users.
     --
diff --git a/src/Distribution/Server/Framework/Auth.hs b/src/Distribution/Server/Framework/Auth.hs
diff --git a/src/Distribution/Server/Framework/ServerEnv.hs b/src/Distribution/Server/Framework/ServerEnv.hs
diff --git a/src/Distribution/Server/Util/ServeTarball.hs b/src/Distribution/Server/Util/ServeTarball.hs
