stability, security and sanity tweaks

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

@@ -95,21 +95,25 @@
         $if(package.optional.hasHomePage)$
         <tr>
           <th>Home page</th>
-          <td>
-            <a href=$package.optional.homepage$>
-              $package.optional.homepage$
-            </a>
+          <td class="word-wrap">
+            $if(package.optional.homepageIsSafeURI)$
+            <a href="$package.optional.homepage$">$package.optional.homepage$</a>
+            $else$
+            $package.optional.homepage$
+            $endif$
           </td>
         </tr>
         $endif$
 
         $if(package.optional.hasBugTracker)$
         <tr>
           <th>Bug&nbsp;tracker</th>
-          <td>
-            <a href="$package.optional.bugTracker$">
-              $package.optional.bugTracker$
-            </a>
+          <td class="word-wrap">
+            $if(package.optional.bugTrackerIsSafeURI)$
+            <a href="$package.optional.bugTracker$">$package.optional.bugTracker$</a>
+            $else$
+            $package.optional.bugTracker$
+            $endif$
           </td>
         </tr>
         $endif$

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

@@ -204,7 +204,11 @@
             <tr>
               <th>Home page</th>
               <td class="word-wrap">
-                <a href=$package.optional.homepage$>$package.optional.homepage$</a>
+                $if(package.optional.homepageIsSafeURI)$
+                <a href="$package.optional.homepage$">$package.optional.homepage$</a>
+                $else$
+                $package.optional.homepage$
+                $endif$
               </td>
             </tr>
             $endif$
@@ -213,7 +217,11 @@
             <tr>
               <th>Bug&nbsp;tracker</th>
               <td class="word-wrap">
+                $if(package.optional.bugTrackerIsSafeURI)$
                 <a href="$package.optional.bugTracker$">$package.optional.bugTracker$</a>
+                $else$
+                $package.optional.bugTracker$
+                $endif$
               </td>
             </tr>
             $endif$

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

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 =

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,15 +178,15 @@ 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
                 ++ nameEntries
                 ++ 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 ]
+-}

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

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."
+                ]

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
-