Serve user-uploaded documentation from separate host name

ysangkok · ysangkok · commit 5a0dc3357b04 · 2025-03-04T07:40:44.000-06:00
diff --git a/exes/Main.hs b/exes/Main.hs
@@ -38,7 +38,7 @@ import System.Directory
 import System.FilePath
          ( (</>), (<.>) )
 import Network.URI
-         ( URI(..), URIAuth(..), parseAbsoluteURI )
+         ( URI(..), parseAbsoluteURI )
 import Distribution.Simple.Command
 import Distribution.Simple.Setup
          ( Flag(..), fromFlag, fromFlagOrDefault, flagToList, flagToMaybe )
@@ -197,6 +197,7 @@ data RunFlags = RunFlags {
     flagRunPort            :: Flag String,
     flagRunIP              :: Flag String,
     flagRunHostURI         :: Flag String,
+    flagRunUserContentURI  :: Flag String,
     flagRunStateDir        :: Flag FilePath,
     flagRunStaticDir       :: Flag FilePath,
     flagRunTmpDir          :: Flag FilePath,
@@ -215,6 +216,7 @@ defaultRunFlags = RunFlags {
     flagRunPort            = NoFlag,
     flagRunIP              = NoFlag,
     flagRunHostURI         = NoFlag,
+    flagRunUserContentURI  = NoFlag,
     flagRunStateDir        = NoFlag,
     flagRunStaticDir       = NoFlag,
     flagRunTmpDir          = NoFlag,
@@ -264,6 +266,10 @@ 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)"
+          flagRunUserContentURI (\v flags -> flags { flagRunUserContentURI = v })
+          (reqArgFlag "NAME")
       , optionStateDir
           flagRunStateDir (\v flags -> flags { flagRunStateDir = v })
       , optionStaticDir
@@ -307,6 +313,7 @@ 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))
     cacheDelay <- checkCacheDelay defaults (flagToMaybe (flagRunCacheDelay opts))
     let stateDir  = fromFlagOrDefault (confStateDir  defaults) (flagRunStateDir  opts)
         staticDir = fromFlagOrDefault (confStaticDir defaults) (flagRunStaticDir opts)
@@ -317,6 +324,7 @@ runAction opts = do
                     }
         config    = defaults {
                         confHostUri    = hosturi,
+                        confUserContentHost = usercontenthost,
                         confListenOn   = listenOn,
                         confStateDir   = stateDir,
                         confStaticDir  = staticDir,
@@ -370,16 +378,7 @@ runAction opts = do
                -> return n
       _        -> fail $ "bad port number " ++ show str
 
-    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 defaults Nothing _ = fail "You must provide the --base-uri= flag"
     checkHostURI _        (Just str) _ = case parseAbsoluteURI str of
       Nothing -> fail $ "Cannot parse as a URI: " ++ str ++ "\n"
                      ++ "Make sure you include the http:// part"
@@ -394,6 +393,9 @@ runAction opts = do
               ++ " the domain, 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
+
     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,7 @@ data ListenOn = ListenOn {
 data ServerConfig = ServerConfig {
   confVerbosity :: Verbosity,
   confHostUri   :: URI,
+  confUserContentHost :: String,
   confListenOn  :: ListenOn,
   confStateDir  :: FilePath,
   confStaticDir :: FilePath,
@@ -96,6 +97,7 @@ defaultServerConfig = do
                       uriScheme    = "http:",
                       uriAuthority = Just (URIAuth "" hostName (':' : show portnum))
                     },
+    confUserContentHost = "",
     confListenOn  = ListenOn {
                         loPortNum = 8080,
                         loIP = "127.0.0.1"
@@ -122,7 +124,7 @@ hasSavedState :: ServerConfig -> IO Bool
 hasSavedState = doesDirectoryExist . confDbStateDir
 
 mkServerEnv :: ServerConfig -> IO ServerEnv
-mkServerEnv config@(ServerConfig verbosity hostURI _
+mkServerEnv config@(ServerConfig verbosity hostURI userContentHost _
                                     stateDir _ tmpDir
                                     cacheDelay liveTemplates) = do
     createDirectoryIfMissing False stateDir
@@ -147,6 +149,7 @@ mkServerEnv config@(ServerConfig verbosity hostURI _
             serverTmpDir        = tmpDir,
             serverCacheDelay    = cacheDelay * 1000000, --microseconds
             serverBaseURI       = hostURI,
+            serverUserContentHost = userContentHost,
             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
@@ -3,7 +3,7 @@
 -- We authenticate clients using HTTP Basic or Digest authentication and we
 -- authorise users based on membership of particular user groups.
 --
-{-# LANGUAGE LambdaCase, PatternGuards #-}
+{-# LANGUAGE LambdaCase, PatternGuards, NamedFieldPuns #-}
 module Distribution.Server.Framework.Auth (
     -- * Checking authorisation
     guardAuthorised,
@@ -39,6 +39,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 Happstack.Server
 
@@ -77,9 +78,10 @@ adminRealm   = RealmName "Hackage admin"
 --     certain privileged actions.
 --
 guardAuthorised :: RealmName -> Users.Users -> [PrivilegeCondition]
+                -> ServerEnv
                 -> ServerPartE UserId
-guardAuthorised realm users privconds = do
-    (uid, _) <- guardAuthenticated realm users
+guardAuthorised realm users privconds env = do
+    (uid, _) <- guardAuthenticated realm users env
     guardPriviledged users uid privconds
     return uid
 
@@ -93,22 +95,26 @@ guardAuthorised realm users privconds = do
 -- It only checks the user is known, it does not imply that the user is
 -- authorised to do anything in particular, see 'guardAuthorised'.
 --
-guardAuthenticated :: RealmName -> Users.Users -> ServerPartE (UserId, UserInfo)
-guardAuthenticated realm users = do
-    authres <- checkAuthenticated realm users
+guardAuthenticated :: RealmName -> Users.Users -> ServerEnv -> ServerPartE (UserId, UserInfo)
+guardAuthenticated realm users env = do
+    authres <- checkAuthenticated realm users env
     case authres of
       Left  autherr -> throwError =<< authErrorResponse realm autherr
       Right info    -> return info
 
-checkAuthenticated :: ServerMonad m => RealmName -> Users.Users -> m (Either AuthError (UserId, UserInfo))
-checkAuthenticated realm users = do
-    req <- askRq
-    return $ case getHeaderAuth req of
-      Just (DigestAuth, ahdr) -> checkDigestAuth users       ahdr req
-      Just _ | plainHttp req  -> Left InsecureAuthError
-      Just (BasicAuth,  ahdr) -> checkBasicAuth  users realm ahdr
-      Just (AuthToken,  ahdr) -> checkTokenAuth  users       ahdr
-      Nothing                 -> Left NoAuthError
+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 })
+       Nothing -> do
+         req <- askRq
+         return $ case getHeaderAuth req of
+           Just (DigestAuth, ahdr) -> checkDigestAuth users       ahdr req
+           Just _ | plainHttp req  -> Left InsecureAuthError
+           Just (BasicAuth,  ahdr) -> checkBasicAuth  users realm ahdr
+           Just (AuthToken,  ahdr) -> checkTokenAuth  users       ahdr
+           Nothing                 -> Left NoAuthError
   where
     getHeaderAuth :: Request -> Maybe (AuthType, BS.ByteString)
     getHeaderAuth req =
@@ -424,6 +430,7 @@ data AuthError = NoAuthError
                | UserStatusError       UserId UserInfo
                | PasswordMismatchError UserId UserInfo
                | BadApiKeyError
+               | BadHost { actualHost :: BS.ByteString, oughtToBeHost :: String }
   deriving Show
 
 authErrorResponse :: MonadIO m => RealmName -> AuthError -> m ErrorResponse
@@ -449,6 +456,9 @@ authErrorResponse realm autherr = do
         BadApiKeyError ->
           ErrorResponse 401 [digestHeader] "Bad auth token" []
 
+        BadHost {} ->
+          ErrorResponse 401 [digestHeader] "Bad host" []
+
         -- we don't want to leak info for the other cases, so same message for them all:
         _ ->
           ErrorResponse 401 [digestHeader] "Username or password incorrect" []
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
