diff --git a/datafiles/templates/Html/candidate-page.html.st b/datafiles/templates/Html/candidate-page.html.st
index c7006d9c0..73737b847 100644
--- a/datafiles/templates/Html/candidate-page.html.st
+++ b/datafiles/templates/Html/candidate-page.html.st
@@ -95,10 +95,12 @@
$if(package.optional.hasHomePage)$
| Home page |
-
-
- $package.optional.homepage$
-
+ |
+ $if(package.optional.homepageIsSafeURI)$
+ $package.optional.homepage$
+ $else$
+ $package.optional.homepage$
+ $endif$
|
$endif$
@@ -106,10 +108,12 @@
$if(package.optional.hasBugTracker)$
| Bug tracker |
-
-
- $package.optional.bugTracker$
-
+ |
+ $if(package.optional.bugTrackerIsSafeURI)$
+ $package.optional.bugTracker$
+ $else$
+ $package.optional.bugTracker$
+ $endif$
|
$endif$
diff --git a/datafiles/templates/Html/package-page.html.st b/datafiles/templates/Html/package-page.html.st
index 941c64a7d..4a42b83c8 100644
--- a/datafiles/templates/Html/package-page.html.st
+++ b/datafiles/templates/Html/package-page.html.st
@@ -204,7 +204,11 @@
| Home page |
- $package.optional.homepage$
+ $if(package.optional.homepageIsSafeURI)$
+ $package.optional.homepage$
+ $else$
+ $package.optional.homepage$
+ $endif$
|
$endif$
@@ -213,7 +217,11 @@
| Bug tracker |
+ $if(package.optional.bugTrackerIsSafeURI)$
$package.optional.bugTracker$
+ $else$
+ $package.optional.bugTracker$
+ $endif$
|
$endif$
diff --git a/hackage-server.cabal b/hackage-server.cabal
index 02ebb6aa6..ef5c984cd 100644
--- a/hackage-server.cabal
+++ b/hackage-server.cabal
@@ -229,6 +229,7 @@ library
Distribution.Server.Framework.BlobStorage
Distribution.Server.Framework.Cache
Distribution.Server.Framework.Cron
+ Distribution.Server.Framework.CSRF
Distribution.Server.Framework.Error
Distribution.Server.Framework.Logging
Distribution.Server.Framework.Feature
diff --git a/src/Distribution/Server.hs b/src/Distribution/Server.hs
index fe422e208..d1b944090 100644
--- a/src/Distribution/Server.hs
+++ b/src/Distribution/Server.hs
@@ -32,6 +32,7 @@ import qualified Distribution.Server.Framework.Auth as Auth
import Distribution.Server.Framework.Templating (TemplatesMode(..))
import Distribution.Server.Framework.AuthTypes (PasswdPlain(..))
import Distribution.Server.Framework.HtmlFormWrapper (htmlFormWrapperHack)
+import Distribution.Server.Framework.CSRF (csrfMiddleware)
import Distribution.Server.Framework.Feature as Feature
import qualified Distribution.Server.Features as Features
@@ -301,10 +302,9 @@ initState server (admin, pass) = do
impl :: Server -> ServerPart Response
impl server = logExceptions $
runServerPartE $
- handleErrorResponse (serveErrorResponse errHandlers Nothing) $
- renderServerTree [] serverTree
- `mplus`
- fallbackNotFound
+ handleErrorResponse (serveErrorResponse errHandlers Nothing) $ do
+ csrfMiddleware
+ renderServerTree [] serverTree `mplus` fallbackNotFound
where
serverTree :: ServerTree (DynamicPath -> ServerPartE Response)
serverTree =
diff --git a/src/Distribution/Server/Features/Sitemap.hs b/src/Distribution/Server/Features/Sitemap.hs
index 9227d70e7..5a4f865bc 100644
--- a/src/Distribution/Server/Features/Sitemap.hs
+++ b/src/Distribution/Server/Features/Sitemap.hs
@@ -35,7 +35,7 @@ import qualified Data.TarIndex as Tar
import System.FilePath (takeExtension)
data Sitemap
- = Sitemap
+ = Sitemap
{ sitemapIndex :: XMLResponse
, sitemaps :: [XMLResponse]
}
@@ -66,7 +66,7 @@ initSitemapFeature env@ServerEnv{ serverCacheDelay,
return $ \coref@CoreFeature{..}
docsCore@DocumentationFeature{..}
- tagsf@TagsFeature{..}
+ tagsf@TagsFeature{..}
tarf@TarIndexCacheFeature{..} -> do
rec let (feature, updateSitemapCache) =
@@ -178,7 +178,7 @@ generateSitemap :: URI
-> (BlobId -> IO Tar.TarIndex)
-> IO [ByteString]
generateSitemap serverBaseURI pageBuildDate alltags pkgIndex docIndex cachedTarIndex = do
- versionedDocSubEntries <- versionedDocSubEntriesIO
+ -- versionedDocSubEntries <- versionedDocSubEntriesIO
let -- Combine and build sitemap
allEntries = miscEntries
++ tagEntries
@@ -186,7 +186,7 @@ generateSitemap serverBaseURI pageBuildDate alltags pkgIndex docIndex cachedTarI
++ nameVersEntries
++ baseDocEntries
++ versionedDocEntries
- ++ versionedDocSubEntries
+ -- ++ versionedDocSubEntries
pure $ renderSitemap serverBaseURI <$> chunksOf 50000 allEntries
where
-- Misc. pages
@@ -270,6 +270,7 @@ generateSitemap serverBaseURI pageBuildDate alltags pkgIndex docIndex cachedTarI
]
pageBuildDate Monthly 0.25
+{-
-- Versioned doc pages in subdirectories
-- versionedSubDocURIs :: [path :: String]
-- e.g. ["http://myhackage.com/packages/mypackage-1.0.2/docs/Lib.html", ...]
@@ -281,7 +282,7 @@ generateSitemap serverBaseURI pageBuildDate alltags pkgIndex docIndex cachedTarI
pkgIndices <- traverse (\(pkg, blob) -> (pkg,) <$> cachedTarIndex blob) pkgs
pure $ urlsToSitemapEntries
[ prefixPkgURI ++ display (packageId pkg) ++ "/docs" ++ fp
- | (pkg, tarIndex) <- pkgIndices
+ | (pkg, tarIndex) <- pkgIndices
, Just tar <- [Tar.lookup tarIndex ""]
, fp <- entryToPaths "/" tar
, takeExtension fp == ".html"
@@ -290,5 +291,6 @@ generateSitemap serverBaseURI pageBuildDate alltags pkgIndex docIndex cachedTarI
entryToPaths :: FilePath -> Tar.TarIndexEntry -> [FilePath]
entryToPaths _ (Tar.TarFileEntry _) = []
- entryToPaths base (Tar.TarDir content) = map ((base ) . fst) content ++
+ entryToPaths base (Tar.TarDir content) = map ((base ) . fst) content ++
[ file | (folder, entry) <- content, file <- entryToPaths (base folder) entry ]
+-}
\ No newline at end of file
diff --git a/src/Distribution/Server/Framework/Auth.hs b/src/Distribution/Server/Framework/Auth.hs
index 87be49244..c979c53ff 100644
--- a/src/Distribution/Server/Framework/Auth.hs
+++ b/src/Distribution/Server/Framework/Auth.hs
@@ -28,6 +28,10 @@ module Distribution.Server.Framework.Auth (
-- ** Errors
AuthError(..),
authErrorResponse,
+
+ -- ** Internal details
+ AuthMethod(..),
+ probeAttemptedAuthMethod,
) where
import qualified Data.Text as T
@@ -124,20 +128,32 @@ checkAuthenticated realm users ServerEnv { serverRequiredBaseHostHeader } = do
Just (BasicAuth, ahdr) -> checkBasicAuth users realm ahdr
Just (AuthToken, ahdr) -> checkTokenAuth users ahdr
Nothing -> Left NoAuthError
- getHeaderAuth :: Request -> Maybe (AuthType, BS.ByteString)
- getHeaderAuth req =
- case getHeader "authorization" req of
- Just hdr
- | BS.isPrefixOf (BS.pack "Digest ") hdr
- -> Just (DigestAuth, BS.drop 7 hdr)
- | BS.isPrefixOf (BS.pack "X-ApiKey ") hdr
- -> Just (AuthToken, BS.drop 9 hdr)
- | BS.isPrefixOf (BS.pack "Basic ") hdr
- -> Just (BasicAuth, BS.drop 6 hdr)
- _ -> Nothing
-
-data AuthType = BasicAuth | DigestAuth | AuthToken
+-- | Authentication methods supported by hackage-server.
+data AuthMethod
+ = -- | HTTP Basic authentication.
+ BasicAuth
+ | -- | HTTP Digest authentication.
+ DigestAuth
+ | -- | Authentication usinng an API token via the @X-ApiKey@ header.
+ AuthToken
+
+getHeaderAuth :: Request -> Maybe (AuthMethod, BS.ByteString)
+getHeaderAuth req =
+ case getHeader "authorization" req of
+ Just hdr
+ | BS.isPrefixOf (BS.pack "Digest ") hdr
+ -> Just (DigestAuth, BS.drop 7 hdr)
+ | BS.isPrefixOf (BS.pack "X-ApiKey ") hdr
+ -> Just (AuthToken, BS.drop 9 hdr)
+ | BS.isPrefixOf (BS.pack "Basic ") hdr
+ -> Just (BasicAuth, BS.drop 6 hdr)
+ _ -> Nothing
+
+-- | Reads the request headers to determine which @AuthMethod@ the client has attempted to use, if
+-- any. Note that this does not /validate/ the authentication credentials.
+probeAttemptedAuthMethod :: Request -> Maybe AuthMethod
+probeAttemptedAuthMethod = fmap fst . getHeaderAuth
data PrivilegeCondition = InGroup Group.UserGroup
| IsUserId UserId
diff --git a/src/Distribution/Server/Framework/CSRF.hs b/src/Distribution/Server/Framework/CSRF.hs
new file mode 100644
index 000000000..5b3d44821
--- /dev/null
+++ b/src/Distribution/Server/Framework/CSRF.hs
@@ -0,0 +1,55 @@
+-- | Middleware for performing CSRF checks.
+module Distribution.Server.Framework.CSRF (csrfMiddleware) where
+
+import Control.Monad (unless)
+import qualified Data.ByteString.Char8 as BS
+import Distribution.Server.Framework.Auth (AuthMethod (AuthToken), probeAttemptedAuthMethod)
+import Distribution.Server.Framework.Error
+import Distribution.Server.Framework.HtmlFormWrapper (rqRealMethod)
+import Happstack.Server
+
+isCsrfSafe :: Request -> Bool
+isCsrfSafe req
+ | Just AuthToken <- probeAttemptedAuthMethod req = True
+ | rqRealMethod req `elem` safeMethods = True
+ | Just headerSecFetchSite <- getHeader "Sec-Fetch-Site" req =
+ headerSecFetchSite `elem` [BS.pack "same-origin", BS.pack "none"]
+ | Just userAgent <- getHeader "User-Agent" req, whitelistedUA userAgent = True
+ | otherwise = False
+ where
+ safeMethods = [GET, HEAD, OPTIONS]
+ -- TODO make this whitelist configurable
+ whitelistedUA ua =
+ any
+ (`BS.isPrefixOf` ua)
+ -- UA set by `cabal upload` and such
+ [ BS.pack "cabal-install/"
+ , -- Add some other common CLI tools here too?
+ BS.pack "curl/"
+ , -- referenced in this repository. Unclear whether strictly needed, but whitelisting just in case:
+ BS.pack "hackage-import/"
+ , BS.pack "hackage-mirror/"
+ , BS.pack "hackage-build/"
+ , BS.pack "hackage-server-testsuite/"
+ , -- default of HTTP library (used by test suite)
+ BS.pack "haskell-HTTP/"
+ , -- deprecated default of HTTP library
+ BS.pack "hs-http-"
+ ]
+
+-- | Middleware to check for CSRF safety. If the request fails the checks, then we throw a 403 error
+-- with an appropriate message.
+csrfMiddleware :: ServerPartE ()
+csrfMiddleware = do
+ req <- askRq
+ unless (isCsrfSafe req) $ do
+ throwError $
+ ErrorResponse
+ 403
+ []
+ "Forbidden"
+ [ MText
+ "This request fails CSRF protection checks. For automated use cases consider \
+ \switching to API tokens. For browsers, update to a more recent version of \
+ \your browser which supports sec-fetch headers."
+ ]
diff --git a/src/Distribution/Server/Framework/Cron.hs b/src/Distribution/Server/Framework/Cron.hs
index 4a1b1d71a..5799b8d9e 100644
--- a/src/Distribution/Server/Framework/Cron.hs
+++ b/src/Distribution/Server/Framework/Cron.hs
@@ -80,7 +80,7 @@ removeExpiredJobs stateVar =
nextJobTime :: UTCTime -> JobFrequency -> UTCTime
nextJobTime now DailyJobFrequency = now {
utctDay = addDays 1 (utctDay now),
- utctDayTime = 0
+ utctDayTime = secondsToDiffTime (60 * 90) -- 90 minutes after midnight
}
nextJobTime now WeeklyJobFrequency = now {
utctDay = sundayAfter (utctDay now),
@@ -155,4 +155,3 @@ threadDelayUntil target = do
hour :: Num a => a
hour = 60 * 60 * 1000000
-
diff --git a/src/Distribution/Server/Pages/PackageFromTemplate.hs b/src/Distribution/Server/Pages/PackageFromTemplate.hs
index edaa7a07b..82a7f877b 100644
--- a/src/Distribution/Server/Pages/PackageFromTemplate.hs
+++ b/src/Distribution/Server/Pages/PackageFromTemplate.hs
@@ -34,7 +34,7 @@ import Text.XHtml.Strict hiding (p, name, title, content)
import qualified Text.XHtml.Strict as XHtml
import Data.Maybe (maybeToList, fromMaybe, isJust)
-import Data.List (intercalate, intersperse)
+import Data.List (intercalate, intersperse, isPrefixOf)
import System.FilePath.Posix ((), takeFileName, dropTrailingPathSeparator)
import Data.Time.Format (defaultTimeLocale, formatTime)
@@ -210,12 +210,16 @@ packagePageTemplate render
[ templateVal "hasHomePage"
(not . Short.null $ homepage desc)
+ , templateVal "homepageIsSafeURI"
+ (fromShortText (homepage desc) `hasScheme` [uriSchemeHttp, uriSchemeHttps])
, templateVal "homepage"
(homepage desc)
] ++
[ templateVal "hasBugTracker"
(not . Short.null $ bugReports desc)
+ , templateVal "bugTrackerIsSafeURI"
+ (fromShortText (bugReports desc) `hasScheme` [uriSchemeHttp, uriSchemeHttps, uriSchemeMailto])
, templateVal "bugTracker"
(bugReports desc)
] ++
@@ -376,6 +380,16 @@ renderVersion (PackageIdentifier pname pversion) allVersions info =
Nothing -> noHtml
Just str -> " (" +++ (anchor ! [href str] << "info") +++ ")"
+uriSchemeHttp, uriSchemeHttps, uriSchemeMailto :: String
+uriSchemeHttp = "http:"
+uriSchemeHttps = "https:"
+uriSchemeMailto = "mailto:"
+
+-- | Check if string starts with one of the given URI schemes.
+-- Schemes are given __with trailing @:@__.
+hasScheme :: String -> [String] -> Bool
+hasScheme s = any (`isPrefixOf` s)
+
sourceRepositoryToHtml :: SourceRepo -> Html
sourceRepositoryToHtml sr
= toHtml (display (repoKind sr) ++ ": ")
@@ -384,21 +398,20 @@ sourceRepositoryToHtml sr
| (Just url, Nothing, Nothing) <-
(repoLocation sr, repoModule sr, repoBranch sr) ->
concatHtml [toHtml "darcs get ",
- anchor ! [href url] << toHtml url,
+ anchorOrBare url url,
case repoTag sr of
Just tag' -> toHtml (" --tag " ++ tag')
Nothing -> noHtml,
case repoSubdir sr of
Just sd -> toHtml " ("
- +++ (anchor ! [href (url sd)]
- << toHtml sd)
+ +++ anchorOrBare (url sd) sd
+++ toHtml ")"
Nothing -> noHtml]
Just (KnownRepoType Git)
| (Just url, Nothing) <-
(repoLocation sr, repoModule sr) ->
concatHtml [toHtml "git clone ",
- anchor ! [href url] << toHtml url,
+ anchorOrBare url url,
case repoBranch sr of
Just branch -> toHtml (" -b " ++ branch)
Nothing -> noHtml,
@@ -412,7 +425,7 @@ sourceRepositoryToHtml sr
| (Just url, Nothing, Nothing, Nothing) <-
(repoLocation sr, repoModule sr, repoBranch sr, repoTag sr) ->
concatHtml [toHtml "svn checkout ",
- anchor ! [href url] << toHtml url,
+ anchorOrBare url url,
case repoSubdir sr of
Just sd -> toHtml ("(" ++ sd ++ ")")
Nothing -> noHtml]
@@ -420,7 +433,7 @@ sourceRepositoryToHtml sr
| (Just url, Just m, Nothing, Nothing) <-
(repoLocation sr, repoModule sr, repoBranch sr, repoTag sr) ->
concatHtml [toHtml "cvs -d ",
- anchor ! [href url] << toHtml url,
+ anchorOrBare url url,
toHtml (" " ++ m),
case repoSubdir sr of
Just sd -> toHtml ("(" ++ sd ++ ")")
@@ -429,7 +442,7 @@ sourceRepositoryToHtml sr
| (Just url, Nothing) <-
(repoLocation sr, repoModule sr) ->
concatHtml [toHtml "hg clone ",
- anchor ! [href url] << toHtml url,
+ anchorOrBare url url,
case repoBranch sr of
Just branch -> toHtml (" -b " ++ branch)
Nothing -> noHtml,
@@ -443,7 +456,7 @@ sourceRepositoryToHtml sr
| (Just url, Nothing, Nothing) <-
(repoLocation sr, repoModule sr, repoBranch sr) ->
concatHtml [toHtml "bzr branch ",
- anchor ! [href url] << toHtml url,
+ anchorOrBare url url,
case repoTag sr of
Just tag' -> toHtml (" -r " ++ tag')
Nothing -> noHtml,
@@ -454,7 +467,7 @@ sourceRepositoryToHtml sr
| Just url <-
repoLocation sr ->
concatHtml [toHtml "fossil clone ",
- anchor ! [href url] << toHtml url,
+ anchorOrBare url url,
toHtml " ",
toHtml (takeFileName (dropTrailingPathSeparator url) ++ ".fossil")
]
@@ -462,7 +475,7 @@ sourceRepositoryToHtml sr
| (Just url, Nothing, Nothing) <-
(repoLocation sr, repoModule sr, repoTag sr) ->
concatHtml [toHtml "pijul clone ",
- anchor ! [href url] << toHtml url,
+ anchorOrBare url url,
case repoBranch sr of
Just branch -> toHtml (" --from-branch " ++ branch)
Nothing -> noHtml,
@@ -477,12 +490,18 @@ sourceRepositoryToHtml sr
let url = fromMaybe "" $ repoLocation sr
showRepoType (OtherRepoType rt) = rt
showRepoType x = show x
- in concatHtml $ [anchor ! [href url] << toHtml url]
+ in concatHtml $ [anchorOrBare url url]
++ fmap (\r -> toHtml $ ", repo type " ++ showRepoType r) (maybeToList $ repoType sr)
++ fmap (\x -> toHtml $ ", module " ++ x) (maybeToList $ repoModule sr)
++ fmap (\x -> toHtml $ ", branch " ++ x) (maybeToList $ repoBranch sr)
++ fmap (\x -> toHtml $ ", tag " ++ x) (maybeToList $ repoTag sr)
++ fmap (\x -> toHtml $ ", subdir " ++ x) (maybeToList $ repoSubdir sr)
+ where
+ -- only make hyperlink if URI matches acceptable schemes
+ anchorOrBare url text
+ | url `hasScheme` schemes = anchor ! [href url] << toHtml text
+ | otherwise = toHtml text
+ schemes = [uriSchemeHttp, uriSchemeHttps]
-- | Handle how version links are displayed.