From 230d9a5c2f8a49bf1b2a2c64d136b5eaeb6e4908 Mon Sep 17 00:00:00 2001 From: Spencer Janssen Date: Wed, 3 Dec 2025 10:11:37 -0600 Subject: [PATCH 01/11] Fix warnings related to irrefutable 0 binding --- src/Data/StringTable.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Data/StringTable.hs b/src/Data/StringTable.hs index 60b7416dc..5ddc387af 100644 --- a/src/Data/StringTable.hs +++ b/src/Data/StringTable.hs @@ -28,7 +28,7 @@ import Distribution.Server.Framework.MemSize data StringTable id = StringTable !BS.ByteString -- all the strings concatenated - !(A.UArray Int Word32) -- offset table + !(A.UArray Int Word32) -- ^ Invariant: the lower bound of the array is 0 deriving (Show, Typeable) $(deriveSafeCopy 0 'base ''StringTable) @@ -42,7 +42,7 @@ instance MemSize (StringTable id) where lookup :: Enum id => StringTable id -> String -> Maybe id lookup (StringTable bs tbl) str = binarySearch 0 (topBound-1) (BS.pack str) where - (0, topBound) = A.bounds tbl + (_assumedZero, topBound) = A.bounds tbl binarySearch a b key | a > b = Nothing @@ -81,12 +81,12 @@ construct strs = StringTable bs tbl enumStrings :: Enum id => StringTable id -> [String] enumStrings (StringTable bs tbl) = map (BS.unpack . index' bs tbl) [0..h-1] - where (0,h) = A.bounds tbl + where (_assumedZero, h) = A.bounds tbl enumIds :: Enum id => StringTable id -> [id] enumIds (StringTable _ tbl) = map toEnum [0..h-1] - where (0,h) = A.bounds tbl + where (_assumedZero, h) = A.bounds tbl prop :: [String] -> Bool prop strs = From 0e337d9ce2b7930b015e533f404a6a1a322ced35 Mon Sep 17 00:00:00 2001 From: Spencer Janssen Date: Wed, 3 Dec 2025 10:19:26 -0600 Subject: [PATCH 02/11] Silence orphan instance warning --- src/Distribution/Server/Features/ReverseDependencies/State.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Distribution/Server/Features/ReverseDependencies/State.hs b/src/Distribution/Server/Features/ReverseDependencies/State.hs index 7e3992e41..5be1f1240 100644 --- a/src/Distribution/Server/Features/ReverseDependencies/State.hs +++ b/src/Distribution/Server/Features/ReverseDependencies/State.hs @@ -1,6 +1,8 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} +-- for instance MemSize Dependency +{-# OPTIONS_GHC -Wno-orphans #-} module Distribution.Server.Features.ReverseDependencies.State ( NodeId From df5f8663ba41f1654bfffb69995eab04c9c92efa Mon Sep 17 00:00:00 2001 From: Spencer Janssen Date: Wed, 3 Dec 2025 10:24:09 -0600 Subject: [PATCH 03/11] Fix pattern match warning --- src/Distribution/Server/Util/Merge.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/Distribution/Server/Util/Merge.hs b/src/Distribution/Server/Util/Merge.hs index ac124ead3..ce0ef6009 100644 --- a/src/Distribution/Server/Util/Merge.hs +++ b/src/Distribution/Server/Util/Merge.hs @@ -1,6 +1,7 @@ module Distribution.Server.Util.Merge where import Data.Map +import qualified Data.Map.Merge.Strict as MapMerge data MergeResult a b = OnlyInLeft a | InBoth a b | OnlyInRight b @@ -17,4 +18,8 @@ mergeBy cmp = merge LT -> OnlyInLeft x : merge xs (y:ys) mergeMaps :: Ord k => Map k a -> Map k b -> Map k (MergeResult a b) -mergeMaps m1 m2 = unionWith (\(OnlyInLeft a) (OnlyInRight b) -> InBoth a b) (fmap OnlyInLeft m1) (fmap OnlyInRight m2) +mergeMaps = + MapMerge.merge + (MapMerge.mapMissing $ const OnlyInLeft) + (MapMerge.mapMissing $ const OnlyInRight) + (MapMerge.zipWithMatched $ const InBoth) From 5bcd977aac1bf8422276cf92ddee8f56a38f31e4 Mon Sep 17 00:00:00 2001 From: Spencer Janssen Date: Wed, 3 Dec 2025 10:28:06 -0600 Subject: [PATCH 04/11] Fix unused variable warning --- src/Distribution/Client.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Distribution/Client.hs b/src/Distribution/Client.hs index 18f55f3d1..bffa5741f 100644 --- a/src/Distribution/Client.hs +++ b/src/Distribution/Client.hs @@ -274,7 +274,7 @@ responseReadBSL rsp = traverse (fmap BS.fromChunks . brConsume) rsp httpSession :: Verbosity -> String -> Version -> HttpSession a -> IO a -httpSession verbosity agent version (HttpSession action) = do +httpSession _verbosity agent version (HttpSession action) = do manager <- newTlsManager let env = HttpEnv { httpManager = manager , initialHeaders = [ (hUserAgent, BSS.pack $ agent ++ "/" ++ showVersion version) ] From 7cddcf59bd849b337dcf81f545517690bd4c204a Mon Sep 17 00:00:00 2001 From: Spencer Janssen Date: Wed, 3 Dec 2025 10:32:29 -0600 Subject: [PATCH 05/11] Replace list groupBy/head with NonEmpty --- src/Distribution/Server/Packages/PackageIndex.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Distribution/Server/Packages/PackageIndex.hs b/src/Distribution/Server/Packages/PackageIndex.hs index 228e5b768..47ab96aa3 100644 --- a/src/Distribution/Server/Packages/PackageIndex.hs +++ b/src/Distribution/Server/Packages/PackageIndex.hs @@ -69,6 +69,7 @@ import Distribution.Package import Distribution.Types.Dependency import Distribution.Version ( withinRange ) import Distribution.Simple.Utils (lowercase) +import qualified Data.List.NonEmpty as NonEmpty -- | The collection of information about packages from one or more 'PackageDB's. -- @@ -155,9 +156,9 @@ fromList pkgs = mkPackageIndex where fixBucket = -- out of groups of duplicates, later ones mask earlier ones -- but Map.fromListWith (++) constructs groups in reverse order - map head + map NonEmpty.head -- Eq instance for PackageIdentifier is wrong, so use Ord: - . groupBy (\a b -> EQ == comparing packageId a b) + . NonEmpty.groupBy (\a b -> EQ == comparing packageId a b) -- relies on sortBy being a stable sort so we -- can pick consistently among duplicates . sortBy (comparing packageId) From 3282892d0e97335612cabd6cda1e0ee4f9051f34 Mon Sep 17 00:00:00 2001 From: Spencer Janssen Date: Wed, 3 Dec 2025 10:33:08 -0600 Subject: [PATCH 06/11] Replace incomplete pattern with call to error --- src/Distribution/Server/Features/Security/Migration.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Distribution/Server/Features/Security/Migration.hs b/src/Distribution/Server/Features/Security/Migration.hs index b9ee61f50..e88b784ef 100644 --- a/src/Distribution/Server/Features/Security/Migration.hs +++ b/src/Distribution/Server/Features/Security/Migration.hs @@ -172,8 +172,9 @@ readPrecomputedHashes env@ServerEnv{ serverVerbosity = verbosity } = do else throwIO err parseEntry :: String -> (MD5, (SHA256, Length)) - parseEntry line = let [md5, sha256, len] = words line - in (md5, (sha256, read len)) + parseEntry line = case words line of + [md5, sha256, len] -> (md5, (sha256, read len)) + _ -> error $ "Invalid precomputed hash line: " <> show line {------------------------------------------------------------------------------- Migration infrastructure From 880dc82960da698a2a5b2fa9a1ce6fc876cb576c Mon Sep 17 00:00:00 2001 From: Spencer Janssen Date: Wed, 3 Dec 2025 10:33:54 -0600 Subject: [PATCH 07/11] Replace partial head with pattern match --- src/Distribution/Server/Features/PackageCandidates.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Distribution/Server/Features/PackageCandidates.hs b/src/Distribution/Server/Features/PackageCandidates.hs index d0550ebbe..105bd7701 100644 --- a/src/Distribution/Server/Features/PackageCandidates.hs +++ b/src/Distribution/Server/Features/PackageCandidates.hs @@ -304,12 +304,12 @@ candidatesFeature ServerEnv{serverBlobStore = store} where cpiToJSON :: [CandPkgInfo] -> Value cpiToJSON [] = Null -- should never happen - cpiToJSON pkgs = object + cpiToJSON pkgs@(pkg:_) = object [ Key.fromString "name" .= pn , Key.fromString "candidates" .= pvs ] where - pn = T.pack . display . pkgName . candInfoId . head $ pkgs + pn = T.pack . display . pkgName . candInfoId $ pkg pvs = [ object [ Key.fromString "version" .= (T.pack . display . packageVersion . candInfoId) p , Key.fromString "sha256" .= (blobInfoHashSHA256 . pkgTarballGz . fst) tarball ] From 80613cf1fd2e64b161bb8e681a69f11127e92126 Mon Sep 17 00:00:00 2001 From: Spencer Janssen Date: Wed, 3 Dec 2025 10:34:30 -0600 Subject: [PATCH 08/11] Replace call to tail with pattern match --- src/Distribution/Server/Features/EditCabalFiles.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Distribution/Server/Features/EditCabalFiles.hs b/src/Distribution/Server/Features/EditCabalFiles.hs index 6b1154024..28e4b1c79 100644 --- a/src/Distribution/Server/Features/EditCabalFiles.hs +++ b/src/Distribution/Server/Features/EditCabalFiles.hs @@ -168,6 +168,6 @@ instance ToSElem Change where where -- TODO/FIXME: stringly hack what = case what0 of - ('a':'d':'d':'e':'d':_) -> 'A' : tail what0 - ('r':'e':'m':'o':'v':'e':'d':_) -> 'R' : tail what0 - _ -> "Changed " ++ what0 + ('a':what1@('d':'d':'e':'d':_)) -> 'A' : what1 + ('r':what1@('e':'m':'o':'v':'e':'d':_)) -> 'R' : what1 + _ -> "Changed " ++ what0 From baf8a066e271feed4796b3789f29f2c97688d068 Mon Sep 17 00:00:00 2001 From: Spencer Janssen Date: Wed, 3 Dec 2025 10:36:13 -0600 Subject: [PATCH 09/11] Replace call to head with pattern match --- src/Distribution/Server/Features/DownloadCount/State.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Distribution/Server/Features/DownloadCount/State.hs b/src/Distribution/Server/Features/DownloadCount/State.hs index 71d47ca68..718c6a611 100644 --- a/src/Distribution/Server/Features/DownloadCount/State.hs +++ b/src/Distribution/Server/Features/DownloadCount/State.hs @@ -176,9 +176,9 @@ updateHistory (InMemStats day perPkg) (OnDiskStats (NCM _ m)) = updatesMap :: Map.Map PackageName OnDiskPerPkg updatesMap = Map.fromList [ (pkgname, applyUpdates pkgs) - | pkgs <- groupBy ((==) `on` (packageName . fst)) - (cmToList perPkg :: [(PackageId, Int)]) - , let pkgname = packageName (fst (head pkgs)) + | pkgs@((pkgId, _):_) <- groupBy ((==) `on` (packageName . fst)) + (cmToList perPkg :: [(PackageId, Int)]) + , let pkgname = packageName pkgId ] applyUpdates :: [(PackageId, Int)] -> OnDiskPerPkg From 4de722a0de561586d70344c578acb5bba9f9da88 Mon Sep 17 00:00:00 2001 From: Spencer Janssen Date: Wed, 3 Dec 2025 10:41:54 -0600 Subject: [PATCH 10/11] WIP disable Typeable deriving warnings Better to delete the deriving clauses altogether --- hackage-server.cabal | 2 ++ 1 file changed, 2 insertions(+) diff --git a/hackage-server.cabal b/hackage-server.cabal index 50576dfd5..9b80db7d5 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -135,6 +135,8 @@ common language-defaults -Wno-deprecated-flags -Wno-unused-do-bind -Wno-unused-record-wildcards + -- TODO remove all Typeable derivings and remove this flag. Safe since GHC 7.10 + -Wno-deriving-typeable -Werror=incomplete-patterns -Werror=missing-methods From 56ed0ec320f57842f018e32c001d9e25d51b8289 Mon Sep 17 00:00:00 2001 From: Spencer Janssen Date: Wed, 3 Dec 2025 10:50:26 -0600 Subject: [PATCH 11/11] WIP unused variable, possible bug? --- src/Distribution/Server/Features/Core.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Distribution/Server/Features/Core.hs b/src/Distribution/Server/Features/Core.hs index 903ff9c8d..699d2b52d 100644 --- a/src/Distribution/Server/Features/Core.hs +++ b/src/Distribution/Server/Features/Core.hs @@ -763,7 +763,8 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} serveCabalFileRevisionName :: DynamicPath -> ServerPartE Response serveCabalFileRevisionName dpath = do - pkgid1 <- packageTarballInPath dpath + -- TODO bug? Maybe something to do with #1439 + _pkgid1 <- packageTarballInPath dpath pkgid2 <- packageInPath dpath guard (pkgVersion pkgid2 == pkgVersion pkgid2) pkginfo <- packageInPath dpath >>= lookupPackageId