Skip to content

Commit 5a0dc33

Browse files
ysangkokysangkok
committed
Serve user-uploaded documentation from separate host name
1 parent 1bb90f4 commit 5a0dc33

File tree

10 files changed

+171
-54
lines changed

10 files changed

+171
-54
lines changed

‎exes/Main.hs

Lines changed: 13 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -38,7 +38,7 @@ import System.Directory
3838
import System.FilePath
3939
( (</>), (<.>) )
4040
import Network.URI
41-
( URI(..), URIAuth(..), parseAbsoluteURI )
41+
( URI(..), parseAbsoluteURI )
4242
import Distribution.Simple.Command
4343
import Distribution.Simple.Setup
4444
( Flag(..), fromFlag, fromFlagOrDefault, flagToList, flagToMaybe )
@@ -197,6 +197,7 @@ data RunFlags = RunFlags {
197197
flagRunPort :: Flag String,
198198
flagRunIP :: Flag String,
199199
flagRunHostURI :: Flag String,
200+
flagRunUserContentURI :: Flag String,
200201
flagRunStateDir :: Flag FilePath,
201202
flagRunStaticDir :: Flag FilePath,
202203
flagRunTmpDir :: Flag FilePath,
@@ -215,6 +216,7 @@ defaultRunFlags = RunFlags {
215216
flagRunPort = NoFlag,
216217
flagRunIP = NoFlag,
217218
flagRunHostURI = NoFlag,
219+
flagRunUserContentURI = NoFlag,
218220
flagRunStateDir = NoFlag,
219221
flagRunStaticDir = NoFlag,
220222
flagRunTmpDir = NoFlag,
@@ -264,6 +266,10 @@ runCommand =
264266
"Server's public base URI (defaults to machine name)"
265267
flagRunHostURI (\v flags -> flags { flagRunHostURI = v })
266268
(reqArgFlag "NAME")
269+
, option [] ["user-content-host"]
270+
"Server's public user content host name (for untrusted content, defeating XSS style attacks)"
271+
flagRunUserContentURI (\v flags -> flags { flagRunUserContentURI = v })
272+
(reqArgFlag "NAME")
267273
, optionStateDir
268274
flagRunStateDir (\v flags -> flags { flagRunStateDir = v })
269275
, optionStaticDir
@@ -307,6 +313,7 @@ runAction opts = do
307313
port <- checkPortOpt defaults (flagToMaybe (flagRunPort opts))
308314
ip <- checkIPOpt defaults (flagToMaybe (flagRunIP opts))
309315
hosturi <- checkHostURI defaults (flagToMaybe (flagRunHostURI opts)) port
316+
usercontenthost <- checkUserContentHost defaults (flagToMaybe (flagRunUserContentURI opts))
310317
cacheDelay <- checkCacheDelay defaults (flagToMaybe (flagRunCacheDelay opts))
311318
let stateDir = fromFlagOrDefault (confStateDir defaults) (flagRunStateDir opts)
312319
staticDir = fromFlagOrDefault (confStaticDir defaults) (flagRunStaticDir opts)
@@ -317,6 +324,7 @@ runAction opts = do
317324
}
318325
config = defaults {
319326
confHostUri = hosturi,
327+
confUserContentHost = usercontenthost,
320328
confListenOn = listenOn,
321329
confStateDir = stateDir,
322330
confStaticDir = staticDir,
@@ -370,16 +378,7 @@ runAction opts = do
370378
-> return n
371379
_ -> fail $ "bad port number " ++ show str
372380

373-
checkHostURI defaults Nothing port = do
374-
let guessURI = confHostUri defaults
375-
Just authority = uriAuthority guessURI
376-
portStr | port == 80 = ""
377-
| otherwise = ':' : show port
378-
guessURI' = guessURI { uriAuthority = Just authority { uriPort = portStr } }
379-
lognotice verbosity $ "Guessing public URI as " ++ show guessURI'
380-
++ "\n(you can override with the --base-uri= flag)"
381-
return guessURI'
382-
381+
checkHostURI defaults Nothing _ = fail "You must provide the --base-uri= flag"
383382
checkHostURI _ (Just str) _ = case parseAbsoluteURI str of
384383
Nothing -> fail $ "Cannot parse as a URI: " ++ str ++ "\n"
385384
++ "Make sure you include the http:// part"
@@ -394,6 +393,9 @@ runAction opts = do
394393
++ " the domain, so cannot use " ++ uriPath uri
395394
| otherwise -> return uri { uriPath = "" }
396395

396+
checkUserContentHost _ Nothing = fail "You must provide the --user-content-host= flag"
397+
checkUserContentHost _ (Just str) = pure str
398+
397399
checkIPOpt defaults Nothing = return (loIP (confListenOn defaults))
398400
checkIPOpt _ (Just str) =
399401
let pQuad = do ds <- Parse.many1 Parse.digit

‎src/Distribution/Server.hs

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -68,6 +68,7 @@ data ListenOn = ListenOn {
6868
data ServerConfig = ServerConfig {
6969
confVerbosity :: Verbosity,
7070
confHostUri :: URI,
71+
confUserContentHost :: String,
7172
confListenOn :: ListenOn,
7273
confStateDir :: FilePath,
7374
confStaticDir :: FilePath,
@@ -96,6 +97,7 @@ defaultServerConfig = do
9697
uriScheme = "http:",
9798
uriAuthority = Just (URIAuth "" hostName (':' : show portnum))
9899
},
100+
confUserContentHost = "",
99101
confListenOn = ListenOn {
100102
loPortNum = 8080,
101103
loIP = "127.0.0.1"
@@ -122,7 +124,7 @@ hasSavedState :: ServerConfig -> IO Bool
122124
hasSavedState = doesDirectoryExist . confDbStateDir
123125

124126
mkServerEnv :: ServerConfig -> IO ServerEnv
125-
mkServerEnv config@(ServerConfig verbosity hostURI _
127+
mkServerEnv config@(ServerConfig verbosity hostURI userContentHost _
126128
stateDir _ tmpDir
127129
cacheDelay liveTemplates) = do
128130
createDirectoryIfMissing False stateDir
@@ -147,6 +149,7 @@ mkServerEnv config@(ServerConfig verbosity hostURI _
147149
serverTmpDir = tmpDir,
148150
serverCacheDelay = cacheDelay * 1000000, --microseconds
149151
serverBaseURI = hostURI,
152+
serverUserContentHost = userContentHost,
150153
serverVerbosity = verbosity
151154
}
152155
return env

‎src/Distribution/Server/Features/Documentation.hs

Lines changed: 25 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -7,6 +7,7 @@ module Distribution.Server.Features.Documentation (
77
initDocumentationFeature
88
) where
99

10+
import Distribution.Server.Features.Security.SHA256 (sha256)
1011
import Distribution.Server.Framework
1112

1213
import Distribution.Server.Features.Documentation.State
@@ -43,7 +44,8 @@ import Data.Function (fix)
4344

4445
import Data.Aeson (toJSON)
4546
import Data.Maybe
46-
import Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime)
47+
import Data.Time.Calendar (fromGregorian)
48+
import Data.Time.Clock (NominalDiffTime, UTCTime(..), diffUTCTime, getCurrentTime)
4749
import System.Directory (getModificationTime)
4850
import Control.Applicative
4951
import Distribution.Server.Features.PreferredVersions
@@ -154,7 +156,7 @@ documentationFeature :: String
154156
-> Hook PackageId ()
155157
-> DocumentationFeature
156158
documentationFeature name
157-
ServerEnv{serverBlobStore = store, serverBaseURI}
159+
env@ServerEnv{serverBlobStore = store, serverBaseURI}
158160
CoreResource{
159161
packageInPath
160162
, guardValidPackageId
@@ -291,11 +293,29 @@ documentationFeature name
291293
etag = BlobStorage.blobETag blob
292294
-- if given a directory, the default page is index.html
293295
-- the root directory within the tarball is e.g. foo-1.0-docs/
296+
mtime <- liftIO $ getModificationTime tarball
294297
age <- liftIO $ getFileAge tarball
295298
let maxAge = documentationCacheTime age
296-
ServerTarball.serveTarball (display pkgid ++ " documentation")
297-
[{-no index-}] (display pkgid ++ "-docs")
298-
tarball index [Public, maxAge] etag (Just rewriteDocs)
299+
tarServe <-
300+
ServerTarball.serveTarball (display pkgid ++ " documentation")
301+
[{-no index-}] (display pkgid ++ "-docs")
302+
tarball index [Public, maxAge] etag (Just rewriteDocs)
303+
case tarServe of
304+
ServerTarball.TarDir response -> pure response
305+
ServerTarball.TarFile fileContent response -> do
306+
let
307+
digest = show $ sha256 fileContent
308+
-- Because JSON files cannot execute code or affect layout, we don't need to verify anything else
309+
isDocIndex =
310+
case dpath of
311+
("..","doc-index.json") : _ -> True
312+
_ -> False
313+
if mtime < UTCTime (fromGregorian 2025 2 1) 0
314+
|| isDocIndex
315+
|| digest == "548d676b3e5a52cbfef06d7424ec065c1f34c230407f9f5dc002c27a9666bec4" -- quick-jump.min.js
316+
|| digest == "6bd159f6d7b1cfef1bd190f1f5eadcd15d35c6c567330d7465c3c35d5195bc6f" -- quick-jump.css
317+
then pure response
318+
else requireUserContent env response
299319

300320
rewriteDocs :: BSL.ByteString -> BSL.ByteString
301321
rewriteDocs dochtml = case BSL.breakFindAfter (BS.pack "<head>") dochtml of

‎src/Distribution/Server/Features/PackageCandidates.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -609,7 +609,7 @@ candidatesFeature ServerEnv{serverBlobStore = store}
609609
Left err ->
610610
errNotFound "Could not serve package contents" [MText err]
611611
Right (fp, etag, index) ->
612-
serveTarball (display (packageId pkg) ++ " candidate source tarball")
612+
tarServeResponse <$> serveTarball (display (packageId pkg) ++ " candidate source tarball")
613613
["index.html"] (display (packageId pkg)) fp index
614614
[Public, maxAgeMinutes 5] etag Nothing
615615

‎src/Distribution/Server/Features/PackageContents.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -206,7 +206,7 @@ packageContentsFeature CoreFeature{ coreResource = CoreResource{
206206
Left err ->
207207
errNotFound "Could not serve package contents" [MText err]
208208
Right (fp, etag, index) ->
209-
serveTarball (display (packageId pkg) ++ " source tarball")
209+
tarServeResponse <$> serveTarball (display (packageId pkg) ++ " source tarball")
210210
[] (display (packageId pkg)) fp index
211211
[Public, maxAgeDays 30] etag Nothing
212212

‎src/Distribution/Server/Features/UserNotify.hs

Lines changed: 6 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -441,7 +441,7 @@ initUserNotifyFeature :: ServerEnv
441441
-> ReverseFeature
442442
-> VouchFeature
443443
-> IO UserNotifyFeature)
444-
initUserNotifyFeature env@ServerEnv{ serverStateDir, serverTemplatesDir,
444+
initUserNotifyFeature ServerEnv{ serverStateDir, serverTemplatesDir,
445445
serverTemplatesMode } = do
446446
-- Canonical state
447447
notifyState <- notifyStateComponent serverStateDir
@@ -452,7 +452,7 @@ initUserNotifyFeature env@ServerEnv{ serverStateDir, serverTemplatesDir,
452452
[ "user-notify-form.html", "endorsements-complete.txt" ]
453453

454454
return $ \users core uploadfeature adminlog userdetails reports tags revers vouch -> do
455-
let feature = userNotifyFeature env
455+
let feature = userNotifyFeature
456456
users core uploadfeature adminlog userdetails reports tags
457457
revers vouch notifyState templates
458458
return feature
@@ -576,8 +576,7 @@ pkgInfoToPkgId :: PkgInfo -> PackageIdentifier
576576
pkgInfoToPkgId pkgInfo =
577577
PackageIdentifier (packageName pkgInfo) (packageVersion pkgInfo)
578578

579-
userNotifyFeature :: ServerEnv
580-
-> UserFeature
579+
userNotifyFeature :: UserFeature
581580
-> CoreFeature
582581
-> UploadFeature
583582
-> AdminLogFeature
@@ -589,8 +588,7 @@ userNotifyFeature :: ServerEnv
589588
-> StateComponent AcidState NotifyData
590589
-> Templates
591590
-> UserNotifyFeature
592-
userNotifyFeature serverEnv@ServerEnv{serverCron}
593-
UserFeature{..}
591+
userNotifyFeature UserFeature{..}
594592
CoreFeature{..}
595593
UploadFeature{..}
596594
AdminLogFeature{..}
@@ -603,6 +601,7 @@ userNotifyFeature serverEnv@ServerEnv{serverCron}
603601
= UserNotifyFeature {..}
604602

605603
where
604+
ServerEnv {serverCron} = userFeatureServerEnv
606605
userNotifyFeatureInterface = (emptyHackageFeature "user-notify") {
607606
featureDesc = "Notifications to users on metadata updates."
608607
, featureResources = [userNotifyResource] -- TODO we can add json features here for updating prefs
@@ -717,7 +716,7 @@ userNotifyFeature serverEnv@ServerEnv{serverCron}
717716
vouchNotifications <- fmap (, NotifyVouchingCompleted) <$> drainQueuedNotifications
718717

719718
emails <-
720-
getNotificationEmails serverEnv userDetailsFeature users templates $
719+
getNotificationEmails userFeatureServerEnv userDetailsFeature users templates $
721720
concat
722721
[ revisionUploadNotifications
723722
, groupActionNotifications

‎src/Distribution/Server/Features/Users.hs

Lines changed: 10 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -144,7 +144,8 @@ data UserFeature = UserFeature {
144144
-- | For a given user, return all of the URIs for groups they are in.
145145
getGroupIndex :: forall m. (Functor m, MonadIO m) => UserId -> m [String],
146146
-- | For a given URI, get a GroupDescription for it, if one can be found.
147-
getIndexDesc :: forall m. MonadIO m => String -> m GroupDescription
147+
getIndexDesc :: forall m. MonadIO m => String -> m GroupDescription,
148+
userFeatureServerEnv :: ServerEnv
148149
}
149150

150151
instance IsHackageFeature UserFeature where
@@ -227,7 +228,7 @@ deriveJSON (compatAesonOptionsDropPrefix "ui_") ''UserGroupResource
227228

228229
-- TODO: add renaming
229230
initUserFeature :: ServerEnv -> IO (IO UserFeature)
230-
initUserFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMode} = do
231+
initUserFeature serverEnv@ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMode} = do
231232
-- Canonical state
232233
usersState <- usersStateComponent serverStateDir
233234
adminsState <- adminsStateComponent serverStateDir
@@ -261,6 +262,7 @@ initUserFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMod
261262
groupIndex
262263
userAdded authFailHook groupChangedHook
263264
adminG adminR
265+
serverEnv
264266

265267
(adminG, adminR) <- groupResourceAt "/users/admins/" adminGroupDesc
266268

@@ -301,10 +303,11 @@ userFeature :: Templates
301303
-> Hook (GroupDescription, Bool, UserId, UserId, String) ()
302304
-> UserGroup
303305
-> GroupResource
306+
-> ServerEnv
304307
-> (UserFeature, UserGroup)
305308
userFeature templates usersState adminsState
306309
groupIndex userAdded authFailHook groupChangedHook
307-
adminGroup adminResource
310+
adminGroup adminResource userFeatureServerEnv
308311
= (UserFeature {..}, adminGroupDesc)
309312
where
310313
userFeatureInterface = (emptyHackageFeature "users") {
@@ -484,7 +487,7 @@ userFeature templates usersState adminsState
484487
-- See note about "authn" cookie above
485488
guardAuthenticatedWithErrHook :: Users.Users -> ServerPartE UserId
486489
guardAuthenticatedWithErrHook users = do
487-
(uid,_) <- Auth.checkAuthenticated realm users
490+
(uid,_) <- Auth.checkAuthenticated realm users userFeatureServerEnv
488491
>>= either handleAuthError return
489492
addCookie Session (mkCookie "authn" "1")
490493
-- Set-Cookie:authn="1";Path=/;Version="1"
@@ -493,6 +496,8 @@ userFeature templates usersState adminsState
493496
realm = Auth.hackageRealm --TODO: should be configurable
494497

495498
handleAuthError :: Auth.AuthError -> ServerPartE a
499+
handleAuthError Auth.BadHost { actualHost, oughtToBeHost } =
500+
errForbidden "Bad Host" [MText $ "Authenticated resources can only be accessed using the regular server host name " <> oughtToBeHost <> ", but was provided host " <> show actualHost]
496501
handleAuthError err = do
497502
defaultResponse <- Auth.authErrorResponse realm err
498503
overrideResponse <- msum <$> runHook authFailHook err
@@ -513,7 +518,7 @@ userFeature templates usersState adminsState
513518
_ -> pure ()
514519

515520
users <- queryGetUserDb
516-
either (const Nothing) Just `fmap` Auth.checkAuthenticated Auth.hackageRealm users
521+
either (const Nothing) Just `fmap` Auth.checkAuthenticated Auth.hackageRealm users userFeatureServerEnv
517522

518523
-- | Resources representing the collection of known users.
519524
--

‎src/Distribution/Server/Framework/Auth.hs

Lines changed: 25 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -3,7 +3,7 @@
33
-- We authenticate clients using HTTP Basic or Digest authentication and we
44
-- authorise users based on membership of particular user groups.
55
--
6-
{-# LANGUAGE LambdaCase, PatternGuards #-}
6+
{-# LANGUAGE LambdaCase, PatternGuards, NamedFieldPuns #-}
77
module Distribution.Server.Framework.Auth (
88
-- * Checking authorisation
99
guardAuthorised,
@@ -39,6 +39,7 @@ import Distribution.Server.Framework.AuthCrypt
3939
import Distribution.Server.Framework.AuthTypes
4040
import Distribution.Server.Framework.Error
4141
import Distribution.Server.Framework.HtmlFormWrapper (rqRealMethod)
42+
import Distribution.Server.Framework.ServerEnv (ServerEnv, isRegularHost)
4243

4344
import Happstack.Server
4445

@@ -77,9 +78,10 @@ adminRealm = RealmName "Hackage admin"
7778
-- certain privileged actions.
7879
--
7980
guardAuthorised :: RealmName -> Users.Users -> [PrivilegeCondition]
81+
-> ServerEnv
8082
-> ServerPartE UserId
81-
guardAuthorised realm users privconds = do
82-
(uid, _) <- guardAuthenticated realm users
83+
guardAuthorised realm users privconds env = do
84+
(uid, _) <- guardAuthenticated realm users env
8385
guardPriviledged users uid privconds
8486
return uid
8587

@@ -93,22 +95,26 @@ guardAuthorised realm users privconds = do
9395
-- It only checks the user is known, it does not imply that the user is
9496
-- authorised to do anything in particular, see 'guardAuthorised'.
9597
--
96-
guardAuthenticated :: RealmName -> Users.Users -> ServerPartE (UserId, UserInfo)
97-
guardAuthenticated realm users = do
98-
authres <- checkAuthenticated realm users
98+
guardAuthenticated :: RealmName -> Users.Users -> ServerEnv -> ServerPartE (UserId, UserInfo)
99+
guardAuthenticated realm users env = do
100+
authres <- checkAuthenticated realm users env
99101
case authres of
100102
Left autherr -> throwError =<< authErrorResponse realm autherr
101103
Right info -> return info
102104

103-
checkAuthenticated :: ServerMonad m => RealmName -> Users.Users -> m (Either AuthError (UserId, UserInfo))
104-
checkAuthenticated realm users = do
105-
req <- askRq
106-
return $ case getHeaderAuth req of
107-
Just (DigestAuth, ahdr) -> checkDigestAuth users ahdr req
108-
Just _ | plainHttp req -> Left InsecureAuthError
109-
Just (BasicAuth, ahdr) -> checkBasicAuth users realm ahdr
110-
Just (AuthToken, ahdr) -> checkTokenAuth users ahdr
111-
Nothing -> Left NoAuthError
105+
checkAuthenticated :: ServerMonad m => RealmName -> Users.Users -> ServerEnv -> m (Either AuthError (UserId, UserInfo))
106+
checkAuthenticated realm users env = do
107+
mbHostMismatch <- isRegularHost env
108+
case mbHostMismatch of
109+
Just (actualHost, oughtToBeHost) -> pure (Left BadHost { actualHost , oughtToBeHost })
110+
Nothing -> do
111+
req <- askRq
112+
return $ case getHeaderAuth req of
113+
Just (DigestAuth, ahdr) -> checkDigestAuth users ahdr req
114+
Just _ | plainHttp req -> Left InsecureAuthError
115+
Just (BasicAuth, ahdr) -> checkBasicAuth users realm ahdr
116+
Just (AuthToken, ahdr) -> checkTokenAuth users ahdr
117+
Nothing -> Left NoAuthError
112118
where
113119
getHeaderAuth :: Request -> Maybe (AuthType, BS.ByteString)
114120
getHeaderAuth req =
@@ -424,6 +430,7 @@ data AuthError = NoAuthError
424430
| UserStatusError UserId UserInfo
425431
| PasswordMismatchError UserId UserInfo
426432
| BadApiKeyError
433+
| BadHost { actualHost :: BS.ByteString, oughtToBeHost :: String }
427434
deriving Show
428435

429436
authErrorResponse :: MonadIO m => RealmName -> AuthError -> m ErrorResponse
@@ -449,6 +456,9 @@ authErrorResponse realm autherr = do
449456
BadApiKeyError ->
450457
ErrorResponse 401 [digestHeader] "Bad auth token" []
451458

459+
BadHost {} ->
460+
ErrorResponse 401 [digestHeader] "Bad host" []
461+
452462
-- we don't want to leak info for the other cases, so same message for them all:
453463
_ ->
454464
ErrorResponse 401 [digestHeader] "Username or password incorrect" []

0 commit comments

Comments
 (0)