From d292789dd2bd8f0ba4d815ef4f3ab11e96b4f9ff Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?H=C3=A9cate=20Kleidukos?= Date: Tue, 1 Apr 2025 13:58:30 +0200 Subject: [PATCH 01/10] Add uploader's username to package json API --- src/Distribution/Server/Features.hs | 1 + .../Server/Features/PackageInfoJSON.hs | 23 ++++++++++++------- .../Server/Features/PackageInfoJSON/State.hs | 16 ++++++++----- src/Distribution/Server/Users/Types.hs | 6 +++-- 4 files changed, 30 insertions(+), 16 deletions(-) diff --git a/src/Distribution/Server/Features.hs b/src/Distribution/Server/Features.hs index b4e2d96d5..9755fce2d 100644 --- a/src/Distribution/Server/Features.hs +++ b/src/Distribution/Server/Features.hs @@ -379,6 +379,7 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do packageInfoJSONFeature <- mkPackageJSONFeature coreFeature versionsFeature + usersFeature #endif diff --git a/src/Distribution/Server/Features/PackageInfoJSON.hs b/src/Distribution/Server/Features/PackageInfoJSON.hs index ceabedefd..2bcdc7781 100644 --- a/src/Distribution/Server/Features/PackageInfoJSON.hs +++ b/src/Distribution/Server/Features/PackageInfoJSON.hs @@ -54,6 +54,8 @@ import Data.Foldable (toList) import Data.Traversable (for) import qualified Data.List as List import Data.Time (UTCTime) +import Distribution.Server.Users.Types (UserName, UserInfo(..)) +import Distribution.Server.Features.Users (UserFeature(lookupUserInfo)) data PackageInfoJSONFeature = PackageInfoJSONFeature { @@ -79,10 +81,10 @@ data PackageInfoJSONResource = PackageInfoJSONResource { -- line for a package when it changes initPackageInfoJSONFeature :: Framework.ServerEnv - -> IO (CoreFeature -> Preferred.VersionsFeature -> IO PackageInfoJSONFeature) + -> IO (CoreFeature -> Preferred.VersionsFeature -> UserFeature -> IO PackageInfoJSONFeature) initPackageInfoJSONFeature env = do packageInfoState <- packageInfoStateComponent False (Framework.serverStateDir env) - return $ \core preferred -> do + return $ \core preferred userFeature -> do let coreR = coreResource core info = "Get basic package information: \ @@ -94,13 +96,13 @@ initPackageInfoJSONFeature env = do (Framework.extendResource (corePackagePage coreR)) { Framework.resourceDesc = [(Framework.GET, info)] , Framework.resourceGet = - [("json", servePackageBasicDescription coreR + [("json", servePackageBasicDescription coreR userFeature preferred packageInfoState)] } , (Framework.extendResource (coreCabalFileRev coreR)) { Framework.resourceDesc = [(Framework.GET, vInfo)] , Framework.resourceGet = - [("json", servePackageBasicDescription coreR + [("json", servePackageBasicDescription coreR userFeature preferred packageInfoState)] } ] @@ -133,14 +135,15 @@ initPackageInfoJSONFeature env = do -- | Pure function for extracting basic package info from a Cabal file getBasicDescription - :: UTCTime + :: UserName + -> UTCTime -- ^ Time of upload -> CabalFileText -> Int -- ^ Metadata revision. This will be added to the resulting -- @PackageBasicDescription@ -> Either String PackageBasicDescription -getBasicDescription uploadedAt (CabalFileText cf) metadataRev = +getBasicDescription uploader uploadedAt (CabalFileText cf) metadataRev = let parseResult = PkgDescr.parseGenericPackageDescription (BS.toStrict cf) in case PkgDescr.runParseResult parseResult of (_, Right pkg) -> let @@ -154,6 +157,7 @@ getBasicDescription uploadedAt (CabalFileText cf) metadataRev = pbd_homepage = T.pack . fromShortText $ PkgDescr.homepage pkgd pbd_metadata_revision = metadataRev pbd_uploaded_at = uploadedAt + pbd_uploader = uploader in return $ PackageBasicDescription {..} (_, Left (_, perrs)) -> @@ -168,12 +172,13 @@ getBasicDescription uploadedAt (CabalFileText cf) metadataRev = -- A listing of versions and their deprecation states servePackageBasicDescription :: CoreResource + -> UserFeature -> Preferred.VersionsFeature -> Framework.StateComponent Framework.AcidState PackageInfoState -> Framework.DynamicPath -- ^ URI specifying a package and version `e.g. lens or lens-4.11` -> Framework.ServerPartE Framework.Response -servePackageBasicDescription resource preferred packageInfoState dpath = do +servePackageBasicDescription resource userFeature preferred packageInfoState dpath = do let metadataRev :: Maybe Int = lookup "revision" dpath >>= Framework.fromReqURI @@ -220,7 +225,9 @@ servePackageBasicDescription resource preferred packageInfoState dpath = do let cabalFile = metadataRevs Vector.! metadataInd uploadedAt = fst $ uploadInfos Vector.! metadataInd - pkgDescr = getBasicDescription uploadedAt cabalFile metadataInd + uploaderId = snd $ uploadInfos Vector.! metadataInd + uploader <- userName <$> lookupUserInfo userFeature uploaderId + let pkgDescr = getBasicDescription uploader uploadedAt cabalFile metadataInd case pkgDescr of Left e -> Framework.errInternalError [Framework.MText e] Right d -> return d diff --git a/src/Distribution/Server/Features/PackageInfoJSON/State.hs b/src/Distribution/Server/Features/PackageInfoJSON/State.hs index 53adfa242..4c50e278a 100644 --- a/src/Distribution/Server/Features/PackageInfoJSON/State.hs +++ b/src/Distribution/Server/Features/PackageInfoJSON/State.hs @@ -41,7 +41,8 @@ import qualified Distribution.Parsec as Parsec import qualified Distribution.Server.Features.PreferredVersions as Preferred import Distribution.Server.Framework.MemSize (MemSize, - memSize, memSize8) + memSize, memSize9) +import Distribution.Server.Users.Types (UserName) -- | Basic information about a package. These values are @@ -55,6 +56,7 @@ data PackageBasicDescription = PackageBasicDescription , pbd_homepage :: !T.Text , pbd_metadata_revision :: !Int , pbd_uploaded_at :: !UTCTime + , pbd_uploader :: !UserName } deriving (Eq, Show, Generic) instance SafeCopy PackageBasicDescription where @@ -67,6 +69,7 @@ instance SafeCopy PackageBasicDescription where put $ T.encodeUtf8 pbd_homepage put pbd_metadata_revision safePut pbd_uploaded_at + safePut pbd_uploader getCopy = contain $ do licenseStr <- get @@ -80,6 +83,7 @@ instance SafeCopy PackageBasicDescription where pbd_homepage <- T.decodeUtf8 <$> get pbd_metadata_revision <- get pbd_uploaded_at <- safeGet + pbd_uploader <- safeGet return PackageBasicDescription{..} @@ -96,9 +100,9 @@ instance Aeson.ToJSON PackageBasicDescription where , Key.fromString "homepage" .= pbd_homepage , Key.fromString "metadata_revision" .= pbd_metadata_revision , Key.fromString "uploaded_at" .= pbd_uploaded_at + , Key.fromString "uploader" .= pbd_uploader ] - instance Aeson.FromJSON PackageBasicDescription where parseJSON = Aeson.withObject "PackageBasicDescription" $ \obj -> do pbd_version' <- obj .: Key.fromString "license" @@ -114,8 +118,8 @@ instance Aeson.FromJSON PackageBasicDescription where pbd_homepage <- obj .: Key.fromString "homepage" pbd_metadata_revision <- obj .: Key.fromString "metadata_revision" pbd_uploaded_at <- obj .: Key.fromString "uploaded_at" - return $ - PackageBasicDescription {..} + pbd_uploader <- obj .: Key.fromString "uploader" + return $ PackageBasicDescription {..} -- | An index of versions for one Hackage package -- and their preferred/deprecated status @@ -229,8 +233,8 @@ deriveSafeCopy 0 'base ''PackageInfoState instance MemSize PackageBasicDescription where memSize PackageBasicDescription{..} = - memSize8 (Pretty.prettyShow pbd_license) pbd_copyright pbd_synopsis - pbd_description pbd_author pbd_homepage pbd_metadata_revision pbd_uploaded_at + memSize9 (Pretty.prettyShow pbd_license) pbd_copyright pbd_synopsis + pbd_description pbd_author pbd_homepage pbd_metadata_revision pbd_uploaded_at pbd_uploader instance MemSize PackageVersions where memSize (PackageVersions ps) = getSum $ diff --git a/src/Distribution/Server/Users/Types.hs b/src/Distribution/Server/Users/Types.hs index 14f484475..f1f62bd74 100644 --- a/src/Distribution/Server/Users/Types.hs +++ b/src/Distribution/Server/Users/Types.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DerivingStrategies #-} module Distribution.Server.Users.Types ( module Distribution.Server.Users.Types, module Distribution.Server.Users.AuthToken, @@ -26,13 +27,14 @@ import Data.Aeson (ToJSON, FromJSON) import Data.SafeCopy (base, extension, deriveSafeCopy, Migrate(..)) import Data.Typeable (Typeable) import Data.Hashable +import Data.Serialize (Serialize) newtype UserId = UserId Int - deriving (Eq, Ord, Read, Show, Typeable, MemSize, ToJSON, FromJSON, Pretty) + deriving newtype (Eq, Ord, Read, Show, Typeable, MemSize, ToJSON, FromJSON, Pretty) newtype UserName = UserName String - deriving (Eq, Ord, Read, Show, Typeable, MemSize, ToJSON, FromJSON, Hashable) + deriving newtype (Eq, Ord, Read, Show, Typeable, MemSize, ToJSON, FromJSON, Hashable, Serialize) data UserInfo = UserInfo { userName :: !UserName, From 2b8e5f611141ea70c2eede86163100f6e72020d1 Mon Sep 17 00:00:00 2001 From: gbaz Date: Tue, 8 Apr 2025 23:27:26 -0400 Subject: [PATCH 02/10] fix authentication check bug with new split hosts --- src/Distribution/Server/Framework/Auth.hs | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/src/Distribution/Server/Framework/Auth.hs b/src/Distribution/Server/Framework/Auth.hs index 0c9d38289..2d2ae175b 100644 --- a/src/Distribution/Server/Framework/Auth.hs +++ b/src/Distribution/Server/Framework/Auth.hs @@ -113,11 +113,10 @@ checkAuthenticated realm users ServerEnv { serverRequiredBaseHostHeader } = do { actualHost=Just hostHeaderValue , oughtToBeHost=serverRequiredBaseHostHeader } - else pure $ Left BadHost - { actualHost=Nothing - , oughtToBeHost=serverRequiredBaseHostHeader - } - Nothing -> do + else goCheck + Nothing -> goCheck + where + goCheck = do req <- askRq return $ case getHeaderAuth req of Just (DigestAuth, ahdr) -> checkDigestAuth users ahdr req @@ -125,7 +124,6 @@ checkAuthenticated realm users ServerEnv { serverRequiredBaseHostHeader } = do 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 = case getHeader "authorization" req of From 8eb37c09b5f276a898b8b6fbde80fbe485d41f01 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Fri, 18 Apr 2025 21:53:52 -0400 Subject: [PATCH 03/10] hackage-server/BuildReports: Fix parsing of flag assignments Eventually this should really just use the Cabal `FlagAssignment` type but here I have opted to instead just stay with the status quo and update the parser. Fixes #1383. --- .../Features/BuildReports/BuildReport.hs | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) diff --git a/src/Distribution/Server/Features/BuildReports/BuildReport.hs b/src/Distribution/Server/Features/BuildReports/BuildReport.hs index ef1231cca..232675db8 100644 --- a/src/Distribution/Server/Features/BuildReports/BuildReport.hs +++ b/src/Distribution/Server/Features/BuildReports/BuildReport.hs @@ -366,12 +366,19 @@ newtype FlagAss1 = FlagAss1 (FlagName,Bool) instance Newtype (FlagName,Bool) FlagAss1 instance Parsec FlagAss1 where - parsec = do - -- this is subtly different from Cabal's 'FlagName' parser - name <- P.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-') - case name of - ('-':flag) -> return $ FlagAss1 (mkFlagName flag, False) - flag -> return $ FlagAss1 (mkFlagName flag, True) + parsec = fmap FlagAss1 (posPolarity <|> negPolarity <|> noPolarity) + where + posPolarity = do + P.char '+' + (,) <$> flagName <*> pure True + negPolarity = do + P.char '-' + (,) <$> flagName <*> pure False + noPolarity = + (,) <$> flagName <*> pure True + + -- this is subtly different from Cabal's 'FlagName' parser + flagName = mkFlagName <$> P.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-') instance Pretty FlagAss1 where pretty (FlagAss1 (fn, True)) = Disp.text (unFlagName fn) From c822819c92df49f4e00d513fa4673f5173937471 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Fri, 11 Apr 2025 17:06:28 -0400 Subject: [PATCH 04/10] hackage-build: Port from HTTP to http-client-tls Introduce support for TLS Hackage upstreams to the documentation builder. --- exes/BuildClient.hs | 48 +++++---- hackage-server.cabal | 6 +- src/Distribution/Client.hs | 200 ++++++++++++++++++++++++------------- 3 files changed, 164 insertions(+), 90 deletions(-) diff --git a/exes/BuildClient.hs b/exes/BuildClient.hs index cc9f593fb..1ac11b9c8 100644 --- a/exes/BuildClient.hs +++ b/exes/BuildClient.hs @@ -1,9 +1,10 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} module Main (main) where -import Network.HTTP hiding (password) -import Network.Browser +import Network.HTTP.Types.Header +import Network.HTTP.Types.Status import Network.URI (URI(..)) import Distribution.Client import Distribution.Client.Cron (cron, rethrowSignalsAsExceptions, @@ -26,6 +27,7 @@ import Control.Applicative as App import Control.Exception import Control.Monad import Control.Monad.Trans +import qualified Data.ByteString.Char8 as BSS import qualified Data.ByteString.Lazy as BS import qualified Data.Map as M @@ -51,6 +53,7 @@ import Paths_hackage_server (version) import Data.Aeson (eitherDecode, encode, parseJSON) import Data.Aeson.Types (parseEither) +import Distribution.Server.Framework (resp) data Mode = Help [String] | Init URI [URI] @@ -878,9 +881,6 @@ uploadResults :: Verbosity -> BuildConfig -> DocInfo -> Maybe FilePath uploadResults verbosity config docInfo mdocsTarballFile buildReportFile buildLogFile testLogFile coverageFile installOk = httpSession verbosity "hackage-build" version $ do - -- Make sure we authenticate to Hackage - setAuthorityGen (provideAuthInfo (bc_srcURI config) - (Just (bc_username config, bc_password config))) case mdocsTarballFile of Nothing -> return () Just docsTarballFile -> @@ -888,10 +888,21 @@ uploadResults verbosity config docInfo putBuildFiles config docInfo buildReportFile buildLogFile testLogFile coverageFile installOk +withAuth :: BuildConfig -> Request -> Request +withAuth config req = + noRedirects $ applyBasicAuth (BSS.pack $ bc_username config) (BSS.pack $ bc_password config) req + putDocsTarball :: BuildConfig -> DocInfo -> FilePath -> HttpSession () -putDocsTarball config docInfo docsTarballFile = - requestPUTFile (docInfoDocsURI config docInfo) - "application/x-tar" (Just "gzip") docsTarballFile +putDocsTarball config docInfo docsTarballFile = do + body <- liftIO $ BS.readFile docsTarballFile + req <- withAuth config <$> mkUploadRequest "PUT" uri mimetype mEncoding [] body + runRequest req $ \rsp -> do + rsp' <- responseReadBSL rsp + checkStatus uri rsp' + where + uri = docInfoDocsURI config docInfo + mimetype = "application/x-tar" + mEncoding = Just "gzip" putBuildFiles :: BuildConfig -> DocInfo -> Maybe FilePath -> FilePath -> Maybe FilePath -> Maybe FilePath -> Bool -> HttpSession () @@ -902,22 +913,17 @@ putBuildFiles config docInfo reportFile buildLogFile testLogFile coverageFile in coverageContent <- liftIO $ traverse readFile coverageFile let uri = docInfoReports config docInfo body = encode $ BR.BuildFiles reportContent (Just logContent) testContent coverageContent (not installOk) - setAllowRedirects False - (_, response) <- request Request { - rqURI = uri, - rqMethod = PUT, - rqHeaders = [Header HdrContentType "application/json", - Header HdrContentLength (show (BS.length body))], - rqBody = body - } - case rspCode response of - --TODO: fix server to not do give 303, 201 is more appropriate - (3,0,3) -> return () - _ -> do checkStatus uri response + let headers = [ (hAccept, BSS.pack "application/json") ] + req <- withAuth config <$> mkUploadRequest (BSS.pack "PUT") uri "application/json" Nothing headers body + runRequest req $ \rsp -> do + case statusCode $ responseStatus rsp of + --TODO: fix server to not do give 303, 201 is more appropriate + 303 -> return () + _ -> do rsp' <- responseReadBSL rsp + checkStatus uri rsp' fail "Unexpected response from server." - ------------------------- -- Command line handling ------------------------- diff --git a/hackage-server.cabal b/hackage-server.cabal index 71abc865b..6ef76b484 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -409,6 +409,9 @@ library build-depends: , HStringTemplate ^>= 0.8 , HTTP ^>= 4000.3.16 || ^>= 4000.4.1 + , http-client ^>= 0.7 && < 0.8 + , http-client-tls ^>= 0.3 + , http-types >= 0.10 && < 0.13 , QuickCheck >= 2.14 && < 2.16 , acid-state ^>= 0.16 , async ^>= 2.2.1 @@ -454,6 +457,7 @@ library , stm ^>= 2.5.0 , stringsearch ^>= 0.3.6.6 , tagged ^>= 0.8.5 + , transformers ^>= 0.6 , xhtml >= 3000.2.0.0 && < 3000.4 , xmlgen ^>= 0.6 , xss-sanitize ^>= 0.3.6 @@ -506,7 +510,7 @@ executable hackage-build build-depends: -- version constraints inherited from hackage-server - , HTTP + , http-types -- Runtime dependency only; -- TODO: we have no proper support for this kind of dependencies in cabal diff --git a/src/Distribution/Client.hs b/src/Distribution/Client.hs index 246f61ee7..f0cf567f3 100644 --- a/src/Distribution/Client.hs +++ b/src/Distribution/Client.hs @@ -1,4 +1,6 @@ {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Distribution.Client ( -- * Command line handling validateHackageURI @@ -12,10 +14,17 @@ module Distribution.Client , HttpSession , uriHostName , httpSession + , Request + , mkRequest + , mkUploadRequest + , noRedirects + , applyBasicAuth + , runRequest + , Response(..) + , responseReadBSL , requestGET' , requestPUT , () - , provideAuthInfo -- * TODO: Exported although they appear unused , extractURICredentials , removeURICredentials @@ -27,8 +36,11 @@ module Distribution.Client , checkStatus ) where -import Network.HTTP -import Network.Browser +import Network.HTTP.Client +import Network.HTTP.Client.TLS +import Network.HTTP.Types.Header +import Network.HTTP.Types.Status +import Network.HTTP.Types.Method import Network.URI (URI(..), URIAuth(..), parseURI) import Distribution.Server.Prelude @@ -42,13 +54,15 @@ import Distribution.Verbosity import Distribution.Simple.Utils import Distribution.Text +import Control.Exception +import Control.Monad.Trans.Reader import Data.Version import Data.List -import Control.Exception import Data.Time import Data.Time.Clock.POSIX import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Char8 as BSS import qualified Distribution.Server.Util.GZip as GZip import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar.Entry as Tar @@ -58,6 +72,7 @@ import System.IO.Error import System.FilePath import System.Directory import qualified System.FilePath.Posix as Posix +import Network.HTTP () ------------------------- @@ -71,9 +86,14 @@ validateHackageURI str = case parseURI str of validateHackageURI' :: URI -> Either String URI validateHackageURI' uri - | uriScheme uri /= "http:" = Left $ "only http URLs are supported " ++ show uri + | not $ okayScheme (uriScheme uri) = + Left $ "only http URLs are supported " ++ show uri | isNothing (uriAuthority uri) = Left $ "server name required in URL " ++ show uri | otherwise = Right uri + where + okayScheme "http:" = True + okayScheme "https:" = True + okayScheme _ = False validatePackageIds :: [String] -> Either String [PackageId] validatePackageIds pkgstrs = @@ -220,53 +240,99 @@ extractURICredentials _ = Nothing removeURICredentials :: URI -> URI removeURICredentials uri = uri { uriAuthority = fmap (\auth -> auth { uriUserInfo = "" }) (uriAuthority uri) } -provideAuthInfo :: URI -> Maybe (String, String) -> URI -> String -> IO (Maybe (String, String)) -provideAuthInfo for_uri credentials = \uri _realm -> do - if uriHostName uri == uriHostName for_uri then return credentials - else return Nothing - uriHostName :: URI -> Maybe String uriHostName = fmap uriRegName . uriAuthority -type HttpSession a = BrowserAction (HandleStream ByteString) a +newtype HttpSession a = HttpSession (ReaderT HttpEnv IO a) + deriving (Functor, Applicative, Monad, MonadFail, MonadIO) + +data HttpEnv = HttpEnv { httpManager :: Manager + , initialHeaders :: RequestHeaders + } + +mkRequest + :: Method + -> RequestHeaders + -> URI + -> HttpSession Request +mkRequest meth headers uri = do + req0 <- liftIO $ requestFromURI uri + return $ req0 { method = meth, requestHeaders = headers } + +mkUploadRequest + :: Method + -> URI + -> String -- ^ MIME type + -> Maybe String -- ^ encoding + -> RequestHeaders + -> ByteString -- ^ body + -> HttpSession Request +mkUploadRequest meth uri mimetype mEncoding headers body = do + req <- mkRequest meth (headers ++ headers') uri + return $ req { requestBody = RequestBodyLBS body } + where + headers' = [ (hContentLength, BSS.pack $ show (BS.length body)) + , (hContentType, BSS.pack mimetype) ] + ++ case mEncoding of + Nothing -> [] + Just encoding -> [ (hContentEncoding, BSS.pack encoding) ] + +-- | Prohibit following of redirects. +noRedirects :: Request -> Request +noRedirects req = req { redirectCount = 0 } + +runRequest :: Request + -> (Response BodyReader -> IO a) + -> HttpSession a +runRequest req0 k = HttpSession $ do + env <- ask + let req = req0 { requestHeaders = initialHeaders env ++ requestHeaders req0 } + liftIO $ withResponse req (httpManager env) k + +responseReadBSL :: Response BodyReader -> IO (Response BS.ByteString) +responseReadBSL rsp = + traverse (fmap BS.fromChunks . brConsume) rsp httpSession :: Verbosity -> String -> Version -> HttpSession a -> IO a -httpSession verbosity agent version action = - browse $ do - setUserAgent (agent ++ "/" ++ showVersion version) - setErrHandler dieNoVerbosity - setOutHandler (debug verbosity) - setAllowBasicAuth True - setCheckForProxy True - action +httpSession verbosity agent version (HttpSession action) = do + manager <- newTlsManager + let env = HttpEnv { httpManager = manager + , initialHeaders = [ (hUserAgent, BSS.pack $ agent ++ "/" ++ showVersion version) ] + } + runReaderT action env downloadFile :: URI -> FilePath -> HttpSession () downloadFile uri file = do - out $ "downloading " ++ show uri ++ " to " ++ file + liftIO $ putStrLn $ "downloading " ++ show uri ++ " to " ++ file let etagFile = file <.> "etag" metag <- liftIO $ catchJustDoesNotExistError (Just <$> readFile etagFile) (\_ -> return Nothing) case metag of Just etag -> do - let headers = [mkHeader HdrIfNoneMatch (quote etag)] - (_, rsp) <- request (Request uri GET headers BS.empty) - case rspCode rsp of - (3,0,4) -> out $ file ++ " unchanged with ETag " ++ etag - (2,0,0) -> liftIO $ writeDowloadedFileAndEtag rsp - _ -> err (showFailure uri rsp) + let headers = [(hIfNoneMatch, BSS.pack (quote etag))] + req <- mkRequest "GET" headers uri + runRequest req $ \rsp -> do + case statusCode $ responseStatus rsp of + 304 -> putStrLn $ file ++ " unchanged with ETag " ++ etag + 200 -> writeDowloadedFileAndEtag rsp + _ -> do rsp' <- responseReadBSL rsp + hPutStrLn stderr (showFailure uri rsp') Nothing -> do - (_, rsp) <- request (Request uri GET [] BS.empty) - case rspCode rsp of - (2,0,0) -> liftIO $ writeDowloadedFileAndEtag rsp - _ -> err (showFailure uri rsp) + req <- mkRequest "GET" [] uri + runRequest req $ \rsp -> + case statusCode $ responseStatus rsp of + 200 -> writeDowloadedFileAndEtag rsp + _ -> do rsp' <- responseReadBSL rsp + hPutStrLn stderr (showFailure uri rsp') where writeDowloadedFileAndEtag rsp = do - BS.writeFile file (rspBody rsp) - setETag file (unquote <$> findHeader HdrETag rsp) + bss <- brConsume (responseBody rsp) + BS.writeFile file (BS.fromChunks bss) + setETag file (unquote . BSS.unpack <$> lookup hETag (responseHeaders rsp)) getETag :: FilePath -> IO (Maybe String) getETag file = @@ -298,10 +364,10 @@ unquote s = s -- AAARG! total lack of exception handling in HTTP monad! downloadFile' :: URI -> FilePath -> HttpSession Bool downloadFile' uri file = do - out $ "downloading " ++ show uri ++ " to " ++ file + liftIO $ putStrLn $ "downloading " ++ show uri ++ " to " ++ file mcontent <- requestGET' uri case mcontent of - Nothing -> do out $ "404 " ++ show uri + Nothing -> do liftIO $ putStrLn $ "404 " ++ show uri return False Just content -> do liftIO $ BS.writeFile file content @@ -309,64 +375,62 @@ downloadFile' uri file = do requestGET :: URI -> HttpSession ByteString requestGET uri = do - (_, rsp) <- request (Request uri GET headers BS.empty) - checkStatus uri rsp - return (rspBody rsp) + req <- mkRequest "GET" headers uri + runRequest req $ \rsp -> do + rsp' <- responseReadBSL rsp + checkStatus uri rsp' + return (responseBody rsp') where headers = [] --- Really annoying! +-- | Like 'requestGET' but return @Nothing@ on 404 status. requestGET' :: URI -> HttpSession (Maybe ByteString) requestGET' uri = do - (_, rsp) <- request (Request uri GET headers BS.empty) - case rspCode rsp of - (4,0,4) -> return Nothing - _ -> do checkStatus uri rsp - return (Just (rspBody rsp)) + req <- mkRequest "GET" headers uri + runRequest req $ \rsp -> do + case statusCode $ responseStatus rsp of + 404 -> return Nothing + _ -> do rsp' <- responseReadBSL rsp + checkStatus uri rsp' + return $ Just (responseBody rsp') where headers = [] - requestPUTFile :: URI -> String -> Maybe String -> FilePath -> HttpSession () requestPUTFile uri mime_type mEncoding file = do content <- liftIO $ BS.readFile file requestPUT uri mime_type mEncoding content requestPOST, requestPUT :: URI -> String -> Maybe String -> ByteString -> HttpSession () -requestPOST = requestPOSTPUT POST -requestPUT = requestPOSTPUT PUT +requestPOST = requestPOSTPUT "POST" +requestPUT = requestPOSTPUT "PUT" -requestPOSTPUT :: RequestMethod -> URI -> String -> Maybe String -> ByteString -> HttpSession () +requestPOSTPUT :: Method -> URI -> String -> Maybe String -> ByteString -> HttpSession () requestPOSTPUT meth uri mimetype mEncoding body = do - (_, rsp) <- request (Request uri meth headers body) - checkStatus uri rsp - where - headers = [ Header HdrContentLength (show (BS.length body)) - , Header HdrContentType mimetype ] - ++ case mEncoding of - Nothing -> [] - Just encoding -> [ Header HdrContentEncoding encoding ] - + req <- mkUploadRequest meth uri mimetype mEncoding [] body + runRequest req $ \rsp -> do + rsp' <- responseReadBSL rsp + checkStatus uri rsp' -checkStatus :: URI -> Response ByteString -> HttpSession () -checkStatus uri rsp = case rspCode rsp of +checkStatus :: URI -> Response ByteString -> IO () +checkStatus uri rsp = case statusCode $ responseStatus rsp of -- 200 OK - (2,0,0) -> return () + 200 -> return () -- 201 Created - (2,0,1) -> return () + 201 -> return () -- 201 Created - (2,0,2) -> return () + 202 -> return () -- 204 No Content - (2,0,4) -> return () + 204 -> return () -- 400 Bad Request - (4,0,0) -> liftIO (warn normal (showFailure uri rsp)) >> return () + 400 -> liftIO (warn normal (showFailure uri rsp)) >> return () -- Other - _code -> err (showFailure uri rsp) + _code -> fail (showFailure uri rsp) showFailure :: URI -> Response ByteString -> String showFailure uri rsp = - show (rspCode rsp) ++ " " ++ rspReason rsp ++ show uri - ++ case lookupHeader HdrContentType (rspHeaders rsp) of - Just mimetype | "text/plain" `isPrefixOf` mimetype - -> '\n' : (unpackUTF8 . rspBody $ rsp) + show (responseStatus rsp) ++ show uri + ++ case lookup hContentType (responseHeaders rsp) of + Just mimetype | "text/plain" `BSS.isPrefixOf` mimetype + -> '\n' : (unpackUTF8 . responseBody $ rsp) _ -> "" From 3a2df946ac9e8f0c8ea779687c9a69287720fce7 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Fri, 11 Apr 2025 19:06:16 -0400 Subject: [PATCH 05/10] BuildClient: Drop redundant import --- exes/BuildClient.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/exes/BuildClient.hs b/exes/BuildClient.hs index 1ac11b9c8..bae62bb2e 100644 --- a/exes/BuildClient.hs +++ b/exes/BuildClient.hs @@ -53,7 +53,6 @@ import Paths_hackage_server (version) import Data.Aeson (eitherDecode, encode, parseJSON) import Data.Aeson.Types (parseEither) -import Distribution.Server.Framework (resp) data Mode = Help [String] | Init URI [URI] From f16e75f3869e57a9550266b40e616bbba2d8e664 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Fri, 11 Apr 2025 19:06:42 -0400 Subject: [PATCH 06/10] BuildClient: Drop dead code --- src/Distribution/Client.hs | 58 ++------------------------------------ 1 file changed, 3 insertions(+), 55 deletions(-) diff --git a/src/Distribution/Client.hs b/src/Distribution/Client.hs index f0cf567f3..b776354b7 100644 --- a/src/Distribution/Client.hs +++ b/src/Distribution/Client.hs @@ -25,14 +25,7 @@ module Distribution.Client , requestGET' , requestPUT , () - -- * TODO: Exported although they appear unused - , extractURICredentials - , removeURICredentials , getETag - , downloadFile' - , requestGET - , requestPUTFile - , requestPOST , checkStatus ) where @@ -226,20 +219,6 @@ infixr 5 uri path = uri { uriPath = Posix.addTrailingPathSeparator (uriPath uri) Posix. path } - -extractURICredentials :: URI -> Maybe (String, String) -extractURICredentials uri - | Just authority <- uriAuthority uri - , (username, ':':passwd0) <- break (==':') (uriUserInfo authority) - , let passwd = takeWhile (/='@') passwd0 - , not (null username) - , not (null passwd) - = Just (username, passwd) -extractURICredentials _ = Nothing - -removeURICredentials :: URI -> URI -removeURICredentials uri = uri { uriAuthority = fmap (\auth -> auth { uriUserInfo = "" }) (uriAuthority uri) } - uriHostName :: URI -> Maybe String uriHostName = fmap uriRegName . uriAuthority @@ -361,28 +340,6 @@ unquote ('"':s) = go s go (c:cs) = c : go cs unquote s = s --- AAARG! total lack of exception handling in HTTP monad! -downloadFile' :: URI -> FilePath -> HttpSession Bool -downloadFile' uri file = do - liftIO $ putStrLn $ "downloading " ++ show uri ++ " to " ++ file - mcontent <- requestGET' uri - case mcontent of - Nothing -> do liftIO $ putStrLn $ "404 " ++ show uri - return False - - Just content -> do liftIO $ BS.writeFile file content - return True - -requestGET :: URI -> HttpSession ByteString -requestGET uri = do - req <- mkRequest "GET" headers uri - runRequest req $ \rsp -> do - rsp' <- responseReadBSL rsp - checkStatus uri rsp' - return (responseBody rsp') - where - headers = [] - -- | Like 'requestGET' but return @Nothing@ on 404 status. requestGET' :: URI -> HttpSession (Maybe ByteString) requestGET' uri = do @@ -396,18 +353,9 @@ requestGET' uri = do where headers = [] -requestPUTFile :: URI -> String -> Maybe String -> FilePath -> HttpSession () -requestPUTFile uri mime_type mEncoding file = do - content <- liftIO $ BS.readFile file - requestPUT uri mime_type mEncoding content - -requestPOST, requestPUT :: URI -> String -> Maybe String -> ByteString -> HttpSession () -requestPOST = requestPOSTPUT "POST" -requestPUT = requestPOSTPUT "PUT" - -requestPOSTPUT :: Method -> URI -> String -> Maybe String -> ByteString -> HttpSession () -requestPOSTPUT meth uri mimetype mEncoding body = do - req <- mkUploadRequest meth uri mimetype mEncoding [] body +requestPUT :: URI -> String -> Maybe String -> ByteString -> HttpSession () +requestPUT uri mimetype mEncoding body = do + req <- mkUploadRequest "PUT" uri mimetype mEncoding [] body runRequest req $ \rsp -> do rsp' <- responseReadBSL rsp checkStatus uri rsp' From 795b85ca692375d2f0d5e6e1b414634421f534b5 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Wed, 16 Apr 2025 16:19:39 -0400 Subject: [PATCH 07/10] Improve HTTP failure reporting --- src/Distribution/Client.hs | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/src/Distribution/Client.hs b/src/Distribution/Client.hs index b776354b7..18f55f3d1 100644 --- a/src/Distribution/Client.hs +++ b/src/Distribution/Client.hs @@ -376,9 +376,13 @@ checkStatus uri rsp = case statusCode $ responseStatus rsp of _code -> fail (showFailure uri rsp) showFailure :: URI -> Response ByteString -> String -showFailure uri rsp = - show (responseStatus rsp) ++ show uri - ++ case lookup hContentType (responseHeaders rsp) of - Just mimetype | "text/plain" `BSS.isPrefixOf` mimetype - -> '\n' : (unpackUTF8 . responseBody $ rsp) - _ -> "" +showFailure uri rsp = unlines + [ "error: failed HTTP request" + , " status: " ++ show (responseStatus rsp) + , " url: " ++ show uri + , " response: " ++ + case lookup hContentType (responseHeaders rsp) of + Just mimetype | "text/plain" `BSS.isPrefixOf` mimetype + -> '\n' : (unpackUTF8 . responseBody $ rsp) + _ -> "" + ] From ecc94f01ebf9e0a5d6c27caa1d349a8dad644130 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Sat, 19 Apr 2025 17:50:03 -0400 Subject: [PATCH 08/10] github-ci: Regenerate Moves to Ubuntu 24.04, fixing broken jobs. --- .github/workflows/haskell-ci.yml | 42 +++++++++++++++++--------------- 1 file changed, 23 insertions(+), 19 deletions(-) diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 9445af6be..abc97cb05 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -6,11 +6,11 @@ # # haskell-ci regenerate # -# For more information, see https://github.com/andreasabel/haskell-ci +# For more information, see https://github.com/haskell-CI/haskell-ci # -# version: 0.19.20240630 +# version: 0.19.20250330 # -# REGENDATA ("0.19.20240630",["github","hackage-server.cabal"]) +# REGENDATA ("0.19.20250330",["github","hackage-server.cabal"]) # name: Haskell-CI on: @@ -23,7 +23,7 @@ on: jobs: linux: name: Haskell-CI - Linux - ${{ matrix.compiler }} - runs-on: ubuntu-20.04 + runs-on: ubuntu-24.04 timeout-minutes: 60 container: @@ -74,17 +74,30 @@ jobs: allow-failure: false fail-fast: false steps: - - name: apt + - name: apt-get install run: | apt-get update apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 + apt-get install -y libbrotli-dev libgd-dev + - name: Install GHCup + run: | mkdir -p "$HOME/.ghcup/bin" - curl -sL https://downloads.haskell.org/ghcup/0.1.20.0/x86_64-linux-ghcup-0.1.20.0 > "$HOME/.ghcup/bin/ghcup" + curl -sL https://downloads.haskell.org/ghcup/0.1.50.1/x86_64-linux-ghcup-0.1.50.1 > "$HOME/.ghcup/bin/ghcup" chmod a+x "$HOME/.ghcup/bin/ghcup" + - name: Install cabal-install + run: | + "$HOME/.ghcup/bin/ghcup" install cabal 3.14.1.1-p1 || (cat "$HOME"/.ghcup/logs/*.* && false) + echo "CABAL=$HOME/.ghcup/bin/cabal-3.14.1.1-p1 -vnormal+nowrap" >> "$GITHUB_ENV" + - name: Install GHC (GHCup) + if: matrix.setup-method == 'ghcup' + run: | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) - "$HOME/.ghcup/bin/ghcup" install cabal 3.12.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) - apt-get update - apt-get install -y libbrotli-dev libgd-dev + HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") + HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') + HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') + echo "HC=$HC" >> "$GITHUB_ENV" + echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" + echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" env: HCKIND: ${{ matrix.compilerKind }} HCNAME: ${{ matrix.compiler }} @@ -95,21 +108,12 @@ jobs: echo "LANG=C.UTF-8" >> "$GITHUB_ENV" echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" - HCDIR=/opt/$HCKIND/$HCVER - HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") - HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') - HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') - echo "HC=$HC" >> "$GITHUB_ENV" - echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" - echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" - echo "CABAL=$HOME/.ghcup/bin/cabal-3.12.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" echo "HEADHACKAGE=false" >> "$GITHUB_ENV" echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" - echo "GHCJSARITH=0" >> "$GITHUB_ENV" env: HCKIND: ${{ matrix.compilerKind }} HCNAME: ${{ matrix.compiler }} @@ -225,8 +229,8 @@ jobs: rm -f cabal.project.local $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all - name: save cache - uses: actions/cache/save@v4 if: always() + uses: actions/cache/save@v4 with: key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} path: ~/.cabal/store From 354a7de3b7f21ad1346677df515d8e8ec75016e6 Mon Sep 17 00:00:00 2001 From: gbaz Date: Wed, 30 Apr 2025 03:48:55 -0400 Subject: [PATCH 09/10] Update Documentation.hs quickjump hashcheck --- .../Server/Features/Documentation.hs | 24 +++++++++++++------ 1 file changed, 17 insertions(+), 7 deletions(-) diff --git a/src/Distribution/Server/Features/Documentation.hs b/src/Distribution/Server/Features/Documentation.hs index d50b37b75..020b043d4 100644 --- a/src/Distribution/Server/Features/Documentation.hs +++ b/src/Distribution/Server/Features/Documentation.hs @@ -1,6 +1,6 @@ {-# LANGUAGE RankNTypes, FlexibleContexts, NamedFieldPuns, RecordWildCards, PatternGuards #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase, MultiWayIf #-} module Distribution.Server.Features.Documentation ( DocumentationFeature(..), DocumentationResource(..), @@ -310,12 +310,22 @@ documentationFeature name 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 + isQuickJump = + case dpath of + ("..","quick-jump.min.js") : _ -> True + ("..","quick-jump.css") : _ -> True + _ -> False + if + | isDocIndex || mtime < UTCTime (fromGregorian 2025 2 1) 0 -> pure response + | isQuickJump -> + if digest == "548d676b3e5a52cbfef06d7424ec065c1f34c230407f9f5dc002c27a9666bec4" -- quick-jump.min.js + || digest == "6bd159f6d7b1cfef1bd190f1f5eadcd15d35c6c567330d7465c3c35d5195bc6f" -- quick-jump.css + then pure response + else + -- Because Quick Jump also runs on the package page, and not just on the user content domain, + -- we cannot accept arbitrary user-uploaded content. + errForbidden "Quick Jump hash is not correct" [MText "Accepted Quick Jump hashes are listed in the hackage-server source code."] + | otherwise -> requireUserContent env response rewriteDocs :: BSL.ByteString -> BSL.ByteString rewriteDocs dochtml = case BSL.breakFindAfter (BS.pack "") dochtml of From 1217eb00fd1f0fb9b37dd45e600d143250841cd0 Mon Sep 17 00:00:00 2001 From: gbaz Date: Wed, 30 Apr 2025 03:52:43 -0400 Subject: [PATCH 10/10] 303 -> 301 redirect --- src/Distribution/Server/Framework/ServerEnv.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Distribution/Server/Framework/ServerEnv.hs b/src/Distribution/Server/Framework/ServerEnv.hs index 019342f39..9e4cfdeef 100644 --- a/src/Distribution/Server/Framework/ServerEnv.hs +++ b/src/Distribution/Server/Framework/ServerEnv.hs @@ -13,7 +13,7 @@ import qualified Network.URI as URI import Data.List (find) import Data.Text.Encoding (encodeUtf8) import Happstack.Server (ServerMonad(askRq)) -import Happstack.Server.Response (seeOther, toResponse) +import Happstack.Server.Response (movedPermanently, toResponse) import Happstack.Server.Types (HeaderPair(..), Response, rqHeaders, rqQuery, rqUri) import qualified Hackage.Security.Util.Path as Sec @@ -96,6 +96,6 @@ requireUserContent ServerEnv {serverUserContentBaseURI, serverRequiredBaseHostHe , URI.uriQuery = rqQuery rq } in - seeOther (show uri) (toResponse ()) + movedPermanently (show uri) (toResponse ()) else pure action