Skip to content

Commit 54b7847

Browse files
gbazgbaz
authored
Merge pull request #1475 from haskell/gb/various-tweaks
stability, security and sanity tweaks
2 parents 866279e + 2de3ae4 commit 54b7847

File tree

9 files changed

+150
-46
lines changed

9 files changed

+150
-46
lines changed

‎datafiles/templates/Html/candidate-page.html.st‎

Lines changed: 12 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -95,21 +95,25 @@
9595
$if(package.optional.hasHomePage)$
9696
<tr>
9797
<th>Home page</th>
98-
<td>
99-
<a href=$package.optional.homepage$>
100-
$package.optional.homepage$
101-
</a>
98+
<td class="word-wrap">
99+
$if(package.optional.homepageIsSafeURI)$
100+
<a href="$package.optional.homepage$">$package.optional.homepage$</a>
101+
$else$
102+
$package.optional.homepage$
103+
$endif$
102104
</td>
103105
</tr>
104106
$endif$
105107

106108
$if(package.optional.hasBugTracker)$
107109
<tr>
108110
<th>Bug&nbsp;tracker</th>
109-
<td>
110-
<a href="$package.optional.bugTracker$">
111-
$package.optional.bugTracker$
112-
</a>
111+
<td class="word-wrap">
112+
$if(package.optional.bugTrackerIsSafeURI)$
113+
<a href="$package.optional.bugTracker$">$package.optional.bugTracker$</a>
114+
$else$
115+
$package.optional.bugTracker$
116+
$endif$
113117
</td>
114118
</tr>
115119
$endif$

‎datafiles/templates/Html/package-page.html.st‎

Lines changed: 9 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -204,7 +204,11 @@
204204
<tr>
205205
<th>Home page</th>
206206
<td class="word-wrap">
207-
<a href=$package.optional.homepage$>$package.optional.homepage$</a>
207+
$if(package.optional.homepageIsSafeURI)$
208+
<a href="$package.optional.homepage$">$package.optional.homepage$</a>
209+
$else$
210+
$package.optional.homepage$
211+
$endif$
208212
</td>
209213
</tr>
210214
$endif$
@@ -213,7 +217,11 @@
213217
<tr>
214218
<th>Bug&nbsp;tracker</th>
215219
<td class="word-wrap">
220+
$if(package.optional.bugTrackerIsSafeURI)$
216221
<a href="$package.optional.bugTracker$">$package.optional.bugTracker$</a>
222+
$else$
223+
$package.optional.bugTracker$
224+
$endif$
217225
</td>
218226
</tr>
219227
$endif$

‎hackage-server.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -229,6 +229,7 @@ library
229229
Distribution.Server.Framework.BlobStorage
230230
Distribution.Server.Framework.Cache
231231
Distribution.Server.Framework.Cron
232+
Distribution.Server.Framework.CSRF
232233
Distribution.Server.Framework.Error
233234
Distribution.Server.Framework.Logging
234235
Distribution.Server.Framework.Feature

‎src/Distribution/Server.hs‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -32,6 +32,7 @@ import qualified Distribution.Server.Framework.Auth as Auth
3232
import Distribution.Server.Framework.Templating (TemplatesMode(..))
3333
import Distribution.Server.Framework.AuthTypes (PasswdPlain(..))
3434
import Distribution.Server.Framework.HtmlFormWrapper (htmlFormWrapperHack)
35+
import Distribution.Server.Framework.CSRF (csrfMiddleware)
3536

3637
import Distribution.Server.Framework.Feature as Feature
3738
import qualified Distribution.Server.Features as Features
@@ -301,10 +302,9 @@ initState server (admin, pass) = do
301302
impl :: Server -> ServerPart Response
302303
impl server = logExceptions $
303304
runServerPartE $
304-
handleErrorResponse (serveErrorResponse errHandlers Nothing) $
305-
renderServerTree [] serverTree
306-
`mplus`
307-
fallbackNotFound
305+
handleErrorResponse (serveErrorResponse errHandlers Nothing) $ do
306+
csrfMiddleware
307+
renderServerTree [] serverTree `mplus` fallbackNotFound
308308
where
309309
serverTree :: ServerTree (DynamicPath -> ServerPartE Response)
310310
serverTree =

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

Lines changed: 8 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -35,7 +35,7 @@ import qualified Data.TarIndex as Tar
3535
import System.FilePath (takeExtension)
3636

3737
data Sitemap
38-
= Sitemap
38+
= Sitemap
3939
{ sitemapIndex :: XMLResponse
4040
, sitemaps :: [XMLResponse]
4141
}
@@ -66,7 +66,7 @@ initSitemapFeature env@ServerEnv{ serverCacheDelay,
6666

6767
return $ \coref@CoreFeature{..}
6868
docsCore@DocumentationFeature{..}
69-
tagsf@TagsFeature{..}
69+
tagsf@TagsFeature{..}
7070
tarf@TarIndexCacheFeature{..} -> do
7171

7272
rec let (feature, updateSitemapCache) =
@@ -178,15 +178,15 @@ generateSitemap :: URI
178178
-> (BlobId -> IO Tar.TarIndex)
179179
-> IO [ByteString]
180180
generateSitemap serverBaseURI pageBuildDate alltags pkgIndex docIndex cachedTarIndex = do
181-
versionedDocSubEntries <- versionedDocSubEntriesIO
181+
-- versionedDocSubEntries <- versionedDocSubEntriesIO
182182
let -- Combine and build sitemap
183183
allEntries = miscEntries
184184
++ tagEntries
185185
++ nameEntries
186186
++ nameVersEntries
187187
++ baseDocEntries
188188
++ versionedDocEntries
189-
++ versionedDocSubEntries
189+
-- ++ versionedDocSubEntries
190190
pure $ renderSitemap serverBaseURI <$> chunksOf 50000 allEntries
191191
where
192192
-- Misc. pages
@@ -270,6 +270,7 @@ generateSitemap serverBaseURI pageBuildDate alltags pkgIndex docIndex cachedTarI
270270
]
271271
pageBuildDate Monthly 0.25
272272

273+
{-
273274
-- Versioned doc pages in subdirectories
274275
-- versionedSubDocURIs :: [path :: String]
275276
-- e.g. ["http://myhackage.com/packages/mypackage-1.0.2/docs/Lib.html", ...]
@@ -281,7 +282,7 @@ generateSitemap serverBaseURI pageBuildDate alltags pkgIndex docIndex cachedTarI
281282
pkgIndices <- traverse (\(pkg, blob) -> (pkg,) <$> cachedTarIndex blob) pkgs
282283
pure $ urlsToSitemapEntries
283284
[ prefixPkgURI ++ display (packageId pkg) ++ "/docs" ++ fp
284-
| (pkg, tarIndex) <- pkgIndices
285+
| (pkg, tarIndex) <- pkgIndices
285286
, Just tar <- [Tar.lookup tarIndex ""]
286287
, fp <- entryToPaths "/" tar
287288
, takeExtension fp == ".html"
@@ -290,5 +291,6 @@ generateSitemap serverBaseURI pageBuildDate alltags pkgIndex docIndex cachedTarI
290291
291292
entryToPaths :: FilePath -> Tar.TarIndexEntry -> [FilePath]
292293
entryToPaths _ (Tar.TarFileEntry _) = []
293-
entryToPaths base (Tar.TarDir content) = map ((base </>) . fst) content ++
294+
entryToPaths base (Tar.TarDir content) = map ((base </>) . fst) content ++
294295
[ file | (folder, entry) <- content, file <- entryToPaths (base </> folder) entry ]
296+
-}

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

Lines changed: 29 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -28,6 +28,10 @@ module Distribution.Server.Framework.Auth (
2828
-- ** Errors
2929
AuthError(..),
3030
authErrorResponse,
31+
32+
-- ** Internal details
33+
AuthMethod(..),
34+
probeAttemptedAuthMethod,
3135
) where
3236

3337
import qualified Data.Text as T
@@ -124,20 +128,32 @@ checkAuthenticated realm users ServerEnv { serverRequiredBaseHostHeader } = do
124128
Just (BasicAuth, ahdr) -> checkBasicAuth users realm ahdr
125129
Just (AuthToken, ahdr) -> checkTokenAuth users ahdr
126130
Nothing -> Left NoAuthError
127-
getHeaderAuth :: Request -> Maybe (AuthType, BS.ByteString)
128-
getHeaderAuth req =
129-
case getHeader "authorization" req of
130-
Just hdr
131-
| BS.isPrefixOf (BS.pack "Digest ") hdr
132-
-> Just (DigestAuth, BS.drop 7 hdr)
133-
| BS.isPrefixOf (BS.pack "X-ApiKey ") hdr
134-
-> Just (AuthToken, BS.drop 9 hdr)
135-
| BS.isPrefixOf (BS.pack "Basic ") hdr
136-
-> Just (BasicAuth, BS.drop 6 hdr)
137-
_ -> Nothing
138-
139-
data AuthType = BasicAuth | DigestAuth | AuthToken
140131

132+
-- | Authentication methods supported by hackage-server.
133+
data AuthMethod
134+
= -- | HTTP Basic authentication.
135+
BasicAuth
136+
| -- | HTTP Digest authentication.
137+
DigestAuth
138+
| -- | Authentication usinng an API token via the @X-ApiKey@ header.
139+
AuthToken
140+
141+
getHeaderAuth :: Request -> Maybe (AuthMethod, BS.ByteString)
142+
getHeaderAuth req =
143+
case getHeader "authorization" req of
144+
Just hdr
145+
| BS.isPrefixOf (BS.pack "Digest ") hdr
146+
-> Just (DigestAuth, BS.drop 7 hdr)
147+
| BS.isPrefixOf (BS.pack "X-ApiKey ") hdr
148+
-> Just (AuthToken, BS.drop 9 hdr)
149+
| BS.isPrefixOf (BS.pack "Basic ") hdr
150+
-> Just (BasicAuth, BS.drop 6 hdr)
151+
_ -> Nothing
152+
153+
-- | Reads the request headers to determine which @AuthMethod@ the client has attempted to use, if
154+
-- any. Note that this does not /validate/ the authentication credentials.
155+
probeAttemptedAuthMethod :: Request -> Maybe AuthMethod
156+
probeAttemptedAuthMethod = fmap fst . getHeaderAuth
141157

142158
data PrivilegeCondition = InGroup Group.UserGroup
143159
| IsUserId UserId

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

Lines changed: 55 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,55 @@
1+
-- | Middleware for performing CSRF checks.
2+
module Distribution.Server.Framework.CSRF (csrfMiddleware) where
3+
4+
import Control.Monad (unless)
5+
import qualified Data.ByteString.Char8 as BS
6+
import Distribution.Server.Framework.Auth (AuthMethod (AuthToken), probeAttemptedAuthMethod)
7+
import Distribution.Server.Framework.Error
8+
import Distribution.Server.Framework.HtmlFormWrapper (rqRealMethod)
9+
import Happstack.Server
10+
11+
isCsrfSafe :: Request -> Bool
12+
isCsrfSafe req
13+
| Just AuthToken <- probeAttemptedAuthMethod req = True
14+
| rqRealMethod req `elem` safeMethods = True
15+
| Just headerSecFetchSite <- getHeader "Sec-Fetch-Site" req =
16+
headerSecFetchSite `elem` [BS.pack "same-origin", BS.pack "none"]
17+
| Just userAgent <- getHeader "User-Agent" req, whitelistedUA userAgent = True
18+
| otherwise = False
19+
where
20+
safeMethods = [GET, HEAD, OPTIONS]
21+
-- TODO make this whitelist configurable
22+
whitelistedUA ua =
23+
any
24+
(`BS.isPrefixOf` ua)
25+
-- UA set by `cabal upload` and such
26+
[ BS.pack "cabal-install/"
27+
, -- Add some other common CLI tools here too?
28+
BS.pack "curl/"
29+
, -- referenced in this repository. Unclear whether strictly needed, but whitelisting just in case:
30+
BS.pack "hackage-import/"
31+
, BS.pack "hackage-mirror/"
32+
, BS.pack "hackage-build/"
33+
, BS.pack "hackage-server-testsuite/"
34+
, -- default of HTTP library (used by test suite)
35+
BS.pack "haskell-HTTP/"
36+
, -- deprecated default of HTTP library
37+
BS.pack "hs-http-"
38+
]
39+
40+
-- | Middleware to check for CSRF safety. If the request fails the checks, then we throw a 403 error
41+
-- with an appropriate message.
42+
csrfMiddleware :: ServerPartE ()
43+
csrfMiddleware = do
44+
req <- askRq
45+
unless (isCsrfSafe req) $ do
46+
throwError $
47+
ErrorResponse
48+
403
49+
[]
50+
"Forbidden"
51+
[ MText
52+
"This request fails CSRF protection checks. For automated use cases consider \
53+
\switching to API tokens. For browsers, update to a more recent version of \
54+
\your browser which supports sec-fetch headers."
55+
]

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

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -80,7 +80,7 @@ removeExpiredJobs stateVar =
8080
nextJobTime :: UTCTime -> JobFrequency -> UTCTime
8181
nextJobTime now DailyJobFrequency = now {
8282
utctDay = addDays 1 (utctDay now),
83-
utctDayTime = 0
83+
utctDayTime = secondsToDiffTime (60 * 90) -- 90 minutes after midnight
8484
}
8585
nextJobTime now WeeklyJobFrequency = now {
8686
utctDay = sundayAfter (utctDay now),
@@ -155,4 +155,3 @@ threadDelayUntil target = do
155155

156156
hour :: Num a => a
157157
hour = 60 * 60 * 1000000
158-

0 commit comments

Comments
 (0)