From 27a5acbc7cb7f78f5c178172492f5dad08e5f8a7 Mon Sep 17 00:00:00 2001 From: Mike Pilgrem Date: Sun, 18 Feb 2024 14:08:18 +0000 Subject: [PATCH] Re #126 Allow global hints location to be configured --- ChangeLog.md | 6 +- app/test-pretty-exceptions/Main.hs | 2 + int/Pantry/Types.hs | 171 +++++++++++++++++++++-- package.yaml | 2 +- pantry.cabal | 2 +- src/Pantry.hs | 217 ++++++++++++++++++----------- 6 files changed, 300 insertions(+), 100 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 8056c59c..d1dd5644 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,8 +1,12 @@ # Changelog for pantry -## v0.9.3.3 +## v0.10.0 * Name of tar file of local cache of package index is not hard coded. +* `withPantryConfig` and `withPantryConfig'` require the location of global + hints to be specified. +* `GlobalHintsLocation`, `defaultGlobalHintsLocation`, `globalHintsLocation` and + `parseGlobalHintsLocation` added. ## v0.9.3.2 diff --git a/app/test-pretty-exceptions/Main.hs b/app/test-pretty-exceptions/Main.hs index 2d8be7a1..e6945079 100644 --- a/app/test-pretty-exceptions/Main.hs +++ b/app/test-pretty-exceptions/Main.hs @@ -145,6 +145,8 @@ examples = concat , [ InvalidSnapshot rawSnapshotLocation someExceptionExample | rawSnapshotLocation <- rawSnapshotLocationExamples ] + , [ InvalidGlobalHintsLocation pathAbsDirExample rawPathExample ] + , [ InvalidFilePathGlobalHints rawPathExample ] , [ MismatchedPackageMetadata rawPackageLocationImmutable rawPackageMetadata treeKey packageIdentifierExample | rawPackageLocationImmutable <- rawPackageLocationImmutableExamples , rawPackageMetadata <- rawPackageMetadataExamples diff --git a/int/Pantry/Types.hs b/int/Pantry/Types.hs index a416b54b..02f05ab6 100644 --- a/int/Pantry/Types.hs +++ b/int/Pantry/Types.hs @@ -98,6 +98,8 @@ module Pantry.Types --, resolveSnapshotLocation , snapshotLocation , defaultSnapshotLocation + , globalHintsLocation + , defaultGlobalHintsLocation , SnapName (..) , parseSnapName , RawSnapshotLocation (..) @@ -112,6 +114,8 @@ module Pantry.Types , Snapshot (..) , RawSnapshotPackage (..) , SnapshotPackage (..) + , GlobalHintsLocation (..) + , parseGlobalHintsLocation , parseWantedCompiler , RawPackageMetadata (..) , PackageMetadata (..) @@ -317,6 +321,8 @@ data PantryConfig = PantryConfig -- the maximum number of Casa keys to pull per request. , pcSnapshotLocation :: SnapName -> RawSnapshotLocation -- ^ The location of snapshot synonyms + , pcGlobalHintsLocation :: WantedCompiler -> GlobalHintsLocation + -- ^ The location of global hints } -- | Get the location of a snapshot synonym from the 'PantryConfig'. @@ -330,6 +336,17 @@ snapshotLocation name = do loc <- view $ pantryConfigL.to pcSnapshotLocation pure $ loc name +-- | Get the location of global hints from the 'PantryConfig'. +-- +-- @since 0.9.4 +globalHintsLocation :: + HasPantryConfig env + => WantedCompiler + -> RIO env GlobalHintsLocation +globalHintsLocation wc = do + loc <- view $ pantryConfigL.to pcGlobalHintsLocation + pure $ loc wc + -- | Should we print warnings when loading a cabal file? -- -- @since 0.1.0.0 @@ -1066,6 +1083,8 @@ data PantryException | InvalidOverrideCompiler !WantedCompiler !WantedCompiler | InvalidFilePathSnapshot !Text | InvalidSnapshot !RawSnapshotLocation !SomeException + | InvalidGlobalHintsLocation !(Path Abs Dir) !Text + | InvalidFilePathGlobalHints !Text | MismatchedPackageMetadata !RawPackageLocationImmutable !RawPackageMetadata @@ -1241,6 +1260,17 @@ instance Display PantryException where <> display loc <> ":\n" <> displayShow err + display (InvalidGlobalHintsLocation dir t) = + "Error: [S-926]\n" + <> "Invalid global hints location " + <> displayShow t + <> " relative to directory " + <> displayShow (toFilePath dir) + display (InvalidFilePathGlobalHints t) = + "Error: [S-832]\n" + <> "Specified global hints as file path with " + <> displayShow t + <> ", but not reading from a local file" display (MismatchedPackageMetadata loc pm mtreeKey foundIdent) = "Error: [S-427]\n" <> "Mismatched package metadata for " @@ -1627,6 +1657,23 @@ instance Pretty PantryException where ] <> blankLine <> string (displayException err) + pretty (InvalidGlobalHintsLocation dir t) = + "[S-926]" + <> line + <> fillSep + [ flow "Invalid global hints location" + , style Current (fromString $ T.unpack t) + , flow "relative to directory" + , pretty dir <> "." + ] + pretty (InvalidFilePathGlobalHints t) = + "[S-832]" + <> line + <> fillSep + [ flow "Specified global hints as file path with" + , style File (fromString $ T.unpack t) <> "," + , flow "but not reading from a local file." + ] pretty (MismatchedPackageMetadata loc pm mtreeKey foundIdent) = "[S-427]" <> line @@ -2895,25 +2942,66 @@ parseRawSnapshotLocation t0 = fromMaybe (parseRawSnapshotLocationPath t0) $ parseUrl = parseRequest (T.unpack t0) $> pure (RSLUrl t0 Nothing) -parseRawSnapshotLocationPath :: Text -> Unresolved RawSnapshotLocation -parseRawSnapshotLocationPath t = +parseLocationPath :: + (Text -> PantryException) + -> (Path Abs Dir -> Text -> PantryException) + -> (ResolvedPath File -> a) + -> Text + -> Unresolved a +parseLocationPath invalidPath invalidLocation resolver t = Unresolved $ \case - Nothing -> throwIO $ InvalidFilePathSnapshot t + Nothing -> throwIO $ invalidPath t Just dir -> do - abs' <- resolveFile dir (T.unpack t) `catchAny` \_ -> throwIO (InvalidSnapshotLocation dir t) - pure $ RSLFilePath $ ResolvedPath (RelFilePath t) abs' + abs' <- resolveFile dir (T.unpack t) `catchAny` + \_ -> throwIO (invalidLocation dir t) + pure $ resolver $ ResolvedPath (RelFilePath t) abs' + +parseRawSnapshotLocationPath :: Text -> Unresolved RawSnapshotLocation +parseRawSnapshotLocationPath = parseLocationPath + InvalidFilePathSnapshot + InvalidSnapshotLocation + RSLFilePath + +githubLocation :: Text -> Text -> Text -> Text +githubLocation user repo path =T.concat + [ "https://raw.githubusercontent.com/" + , user + , "/" + , repo + , "/master/" + , path + ] githubSnapshotLocation :: Text -> Text -> Text -> RawSnapshotLocation githubSnapshotLocation user repo path = - let url = T.concat - [ "https://raw.githubusercontent.com/" - , user - , "/" - , repo - , "/master/" - , path - ] - in RSLUrl url Nothing + RSLUrl (githubLocation user repo path) Nothing + +-- | Parse a 'Text' into an 'Unresolved' 'GlobalHintsLocation'. +-- +-- @since 0.9.4 +parseGlobalHintsLocation :: Text -> Unresolved GlobalHintsLocation +parseGlobalHintsLocation t0 = fromMaybe (parseGlobalHintsLocationPath t0) $ + parseGitHub <|> parseUrl + where + parseGitHub = do + t1 <- T.stripPrefix "github:" t0 + let (user, t2) = T.break (== '/') t1 + t3 <- T.stripPrefix "/" t2 + let (repo, t4) = T.break (== ':') t3 + path <- T.stripPrefix ":" t4 + Just $ pure $ githubGlobalHintsLocation user repo path + + parseUrl = parseRequest (T.unpack t0) $> pure (GHLUrl t0) + +parseGlobalHintsLocationPath :: Text -> Unresolved GlobalHintsLocation +parseGlobalHintsLocationPath = parseLocationPath + InvalidFilePathGlobalHints + InvalidGlobalHintsLocation + GHLFilePath + +githubGlobalHintsLocation :: Text -> Text -> Text -> GlobalHintsLocation +githubGlobalHintsLocation user repo path = + GHLUrl (githubLocation user repo path) defUser :: Text defUser = "commercialhaskell" @@ -2921,6 +3009,9 @@ defUser = "commercialhaskell" defRepo :: Text defRepo = "stackage-snapshots" +defGlobalHintsRepo :: Text +defGlobalHintsRepo = "stackage-content" + -- | Default location of snapshot synonyms, i.e. commercialhaskell's GitHub -- repository. -- @@ -2945,6 +3036,17 @@ defaultSnapshotLocation (Nightly date) = where (year, month, day) = toGregorian date +-- | Default location of global hints, i.e. commercialhaskell's GitHub +-- repository. +-- +-- @since 0.9.4 +defaultGlobalHintsLocation :: + WantedCompiler + -> GlobalHintsLocation +defaultGlobalHintsLocation _ = + githubGlobalHintsLocation defUser defGlobalHintsRepo $ + utf8BuilderToText "stack/global-hints.yaml" + -- | A snapshot synonym. It is expanded according to the field -- 'snapshotLocation' of a 'PantryConfig'. -- @@ -3361,3 +3463,44 @@ warnMissingCabalFile loc = <> "This usage is deprecated; please see " <> "https://github.com/commercialhaskell/stack/issues/5210.\n" <> "Support for this workflow will be removed in the future.\n" + +-- | Where to load global hints from. +-- +-- @since 0.9.4 +data GlobalHintsLocation + = GHLUrl !Text + -- ^ Download the global hints from the given URL. + | GHLFilePath !(ResolvedPath File) + -- ^ Global hints at a local file path. + deriving (Show, Eq, Ord, Generic) + +instance NFData GlobalHintsLocation + +instance Display GlobalHintsLocation where + display (GHLUrl url) = display url + display (GHLFilePath resolved) = display (resolvedRelative resolved) + +instance Pretty GlobalHintsLocation where + pretty (GHLUrl url) = style Url (fromString $ T.unpack url) + pretty (GHLFilePath resolved) = + style File (fromString . T.unpack $ textDisplay (resolvedRelative resolved)) + +instance ToJSON GlobalHintsLocation where + toJSON (GHLUrl url) = object ["url" .= url] + toJSON (GHLFilePath resolved) = + object ["filepath" .= resolvedRelative resolved] + +instance FromJSON (WithJSONWarnings (Unresolved GlobalHintsLocation)) where + parseJSON v = file v <|> url v + where + file = withObjectWarnings "GHLFilepath" $ \o -> do + ufp <- o ..: "filepath" + pure $ Unresolved $ \case + Nothing -> throwIO $ InvalidFilePathGlobalHints ufp + Just dir -> do + absolute <- resolveFile dir (T.unpack ufp) + let fp = ResolvedPath (RelFilePath ufp) absolute + pure $ GHLFilePath fp + url = withObjectWarnings "GHLUrl" $ \o -> do + url' <- o ..: "url" + pure $ Unresolved $ \_ -> pure $ GHLUrl url' diff --git a/package.yaml b/package.yaml index 7c6497e1..cb4d7d53 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: pantry -version: 0.9.3.3 +version: 0.10.0 synopsis: Content addressable Haskell package management description: Please see the README on GitHub at category: Development diff --git a/pantry.cabal b/pantry.cabal index 9af82ea5..14f36710 100644 --- a/pantry.cabal +++ b/pantry.cabal @@ -5,7 +5,7 @@ cabal-version: 2.0 -- see: https://github.com/sol/hpack name: pantry -version: 0.9.3.3 +version: 0.10.0 synopsis: Content addressable Haskell package management description: Please see the README on GitHub at category: Development diff --git a/src/Pantry.hs b/src/Pantry.hs index 384136ec..9b3c7e97 100644 --- a/src/Pantry.hs +++ b/src/Pantry.hs @@ -22,6 +22,7 @@ module Pantry , defaultCasaRepoPrefix , defaultCasaMaxPerRequest , defaultSnapshotLocation + , defaultGlobalHintsLocation , HasPantryConfig (..) , withPantryConfig , withPantryConfig' @@ -106,6 +107,9 @@ module Pantry , SnapName (..) , snapshotLocation + -- ** Global hints + , GlobalHintsLocation (..) + -- * Loading values , resolvePaths , loadPackageRaw @@ -252,49 +256,54 @@ import Pantry.Tree ( rawParseGPD, unpackTree ) import Pantry.Types as P ( Archive (..), ArchiveLocation (..), BlobKey (..) , CabalFileInfo (..), CabalString (..), FileSize (..) - , FuzzyResults (..), HackageSecurityConfig (..) - , HasPantryConfig (..), HpackExecutable (..), Mismatch (..) - , ModuleName, Package (..), PackageCabal (..) - , PackageIdentifier (..), PackageIdentifierRevision (..) - , PackageIndexConfig (..), PackageLocation (..) - , PackageLocationImmutable (..), PackageMetadata (..) - , PackageName, PantryConfig (..), PantryException (..) - , PHpack (..), PrintWarnings (..), RawArchive (..) - , RawPackageLocation (..), RawPackageLocationImmutable (..) - , RawPackageMetadata (..), RawSnapshot (..) - , RawSnapshotLayer (..), RawSnapshotLocation (..) - , RawSnapshotPackage (..), RelFilePath (..), Repo (..) - , RepoType (..), ResolvedPath (..), Revision (..) - , SafeFilePath, SHA256, SimpleRepo (..), SnapName (..) - , Snapshot (..), SnapshotCacheHash (..), SnapshotLayer (..) + , FuzzyResults (..), GlobalHintsLocation (..) + , HackageSecurityConfig (..), HasPantryConfig (..) + , HpackExecutable (..), Mismatch (..), ModuleName + , Package (..), PackageCabal (..), PackageIdentifier (..) + , PackageIdentifierRevision (..), PackageIndexConfig (..) + , PackageLocation (..), PackageLocationImmutable (..) + , PackageMetadata (..), PackageName, PantryConfig (..) + , PantryException (..), PHpack (..), PrintWarnings (..) + , RawArchive (..), RawPackageLocation (..) + , RawPackageLocationImmutable (..), RawPackageMetadata (..) + , RawSnapshot (..), RawSnapshotLayer (..) + , RawSnapshotLocation (..), RawSnapshotPackage (..) + , RelFilePath (..), Repo (..), RepoType (..) + , ResolvedPath (..), Revision (..), SafeFilePath, SHA256 + , SimpleRepo (..), SnapName (..), Snapshot (..) + , SnapshotCacheHash (..), SnapshotLayer (..) , SnapshotLocation (..), SnapshotPackage (..), Tree (..) , TreeEntry (..), TreeKey (..), Unresolved, Version , WantedCompiler (..), bsToBlobKey, cabalFileName - , defaultHackageSecurityConfig, defaultSnapshotLocation - , flagNameString, getGlobalHintsFile, mkSafeFilePath - , moduleNameString, packageIdentifierString - , packageNameString, parseFlagName, parseHackageText - , parsePackageIdentifier, parsePackageIdentifierRevision - , parsePackageName, parsePackageNameThrowing - , parseRawSnapshotLocation, parseSnapName, parseTreeM - , parseVersion, parseVersionThrowing, parseWantedCompiler - , pirForHash, resolvePaths, snapshotLocation - , toCabalStringMap, toRawPL, toRawPLI, toRawPM, toRawSL - , toRawSnapshotLayer, unCabalStringMap, unSafeFilePath - , versionString, warnMissingCabalFile + , defaultGlobalHintsLocation, defaultHackageSecurityConfig + , defaultSnapshotLocation, flagNameString, getGlobalHintsFile + , globalHintsLocation, mkSafeFilePath, moduleNameString + , packageIdentifierString, packageNameString, parseFlagName + , parseHackageText, parsePackageIdentifier + , parsePackageIdentifierRevision, parsePackageName + , parsePackageNameThrowing, parseRawSnapshotLocation + , parseSnapName, parseTreeM, parseVersion + , parseVersionThrowing, parseWantedCompiler, pirForHash + , resolvePaths, snapshotLocation, toCabalStringMap, toRawPL + , toRawPLI, toRawPM, toRawSL, toRawSnapshotLayer + , unCabalStringMap, unSafeFilePath, versionString + , warnMissingCabalFile ) import Path ( Abs, Dir, File, Path, (), filename, parent, parseAbsDir , parseRelFile, toFilePath ) -import Path.IO ( doesFileExist, listDir, resolveDir' ) +import Path.IO ( copyFile, doesFileExist, listDir, resolveDir' ) import RIO import qualified RIO.ByteString as B import RIO.Directory ( getAppUserDataDirectory ) import qualified RIO.FilePath as FilePath import qualified RIO.List as List import qualified RIO.Map as Map -import RIO.PrettyPrint ( HasTerm (..) ) +import RIO.PrettyPrint + ( HasTerm (..), blankLine, flow, line, pretty, prettyDebugL + , prettyError, prettyInfoL, string + ) import RIO.PrettyPrint.StylesUpdate ( HasStylesUpdate (..), StylesUpdate ) import RIO.Process @@ -349,6 +358,8 @@ withPantryConfig :: -- ^ Max casa keys to pull per request. -> (SnapName -> RawSnapshotLocation) -- ^ The location of snapshot synonyms + -> (WantedCompiler -> GlobalHintsLocation) + -- ^ The location of global hints -> (PantryConfig -> RIO env a) -- ^ What to do with the config -> RIO env a @@ -378,29 +389,41 @@ withPantryConfig' -- maximum number of Casa keys to pull per request. -> (SnapName -> RawSnapshotLocation) -- ^ The location of snapshot synonyms + -> (WantedCompiler -> GlobalHintsLocation) + -- ^ The location of global hints -> (PantryConfig -> RIO env a) -- ^ What to do with the config -> RIO env a -withPantryConfig' root pic he count mCasaConfig snapLoc inner = do - env <- ask - pantryRelFile <- parseRelFile "pantry.sqlite3" - -- Silence persistent's logging output, which is really noisy - runRIO (mempty :: LogFunc) $ initStorage (root pantryRelFile) $ \storage -> runRIO env $ do - ur <- newMVar True - ref1 <- newIORef mempty - ref2 <- newIORef mempty - inner PantryConfig - { pcPackageIndex = pic - , pcHpackExecutable = he - , pcRootDir = root - , pcStorage = storage - , pcUpdateRef = ur - , pcConnectionCount = count - , pcParsedCabalFilesRawImmutable = ref1 - , pcParsedCabalFilesMutable = ref2 - , pcCasaConfig = mCasaConfig - , pcSnapshotLocation = snapLoc - } +withPantryConfig' + root + pic + he + count + mCasaConfig + snapLoc + globalHintsLoc + inner + = do + env <- ask + pantryRelFile <- parseRelFile "pantry.sqlite3" + -- Silence persistent's logging output, which is really noisy + runRIO (mempty :: LogFunc) $ initStorage (root pantryRelFile) $ \storage -> runRIO env $ do + ur <- newMVar True + ref1 <- newIORef mempty + ref2 <- newIORef mempty + inner PantryConfig + { pcPackageIndex = pic + , pcHpackExecutable = he + , pcRootDir = root + , pcStorage = storage + , pcUpdateRef = ur + , pcConnectionCount = count + , pcParsedCabalFilesRawImmutable = ref1 + , pcParsedCabalFilesMutable = ref2 + , pcCasaConfig = mCasaConfig + , pcSnapshotLocation = snapLoc + , pcGlobalHintsLocation = globalHintsLoc + } -- | Default pull URL for Casa. -- @@ -1925,6 +1948,7 @@ runPantryAppWith maxConnCount casaRepoPrefix casaMaxPerRequest f = runSimpleApp maxConnCount (Just (casaRepoPrefix, casaMaxPerRequest)) defaultSnapshotLocation + defaultGlobalHintsLocation $ \pc -> runRIO PantryApp @@ -1952,6 +1976,7 @@ runPantryAppClean f = 8 (Just (defaultCasaRepoPrefix, defaultCasaMaxPerRequest)) defaultSnapshotLocation + defaultGlobalHintsLocation $ \pc -> runRIO PantryApp @@ -1963,46 +1988,72 @@ runPantryAppClean f = } f --- | Load the global hints from GitHub. +-- | Load the global hints. -- --- @since 0.1.0.0 +-- @since 9.4.0 loadGlobalHints :: (HasTerm env, HasPantryConfig env) => WantedCompiler -> RIO env (Maybe (Map PackageName Version)) -loadGlobalHints wc = - inner False +loadGlobalHints wc = do + dest <- getGlobalHintsFile + loc <- globalHintsLocation wc + inner dest loc False where - inner alreadyDownloaded = do - dest <- getGlobalHintsFile - req <- parseRequest "https://raw.githubusercontent.com/commercialhaskell/stackage-content/master/stack/global-hints.yaml" - downloaded <- download req dest - eres <- tryAny (inner2 dest) - mres <- - case eres of - Left e -> Nothing <$ logError - ( "Error: [S-912]\n" - <> "Error when parsing global hints: " - <> displayShow e - ) - Right x -> pure x - case mres of - Nothing | not alreadyDownloaded && not downloaded -> do - logInfo $ - "Could not find local global hints for " <> - RIO.display wc <> - ", forcing a redownload" - x <- redownload req dest - if x - then inner True - else do - logInfo "Redownload didn't happen" - pure Nothing - _ -> pure mres - - inner2 dest = liftIO $ - Map.lookup wc . fmap (fmap unCabalString . unCabalStringMap) - <$> Yaml.decodeFileThrow (toFilePath dest) + inner dest loc alreadyDownloaded = case loc of + GHLUrl url -> do + req <- parseRequest $ T.unpack url + downloaded <- download req dest + mres <- tryParseYaml dest + case mres of + Nothing | not alreadyDownloaded && not downloaded -> do + prettyInfoL + [ flow "Could not find local global hints for" + , string (T.unpack $ RIO.textDisplay wc) <> "," + , flow "forcing a redownload." + ] + redownloaded <- redownload req dest + if redownloaded + then inner dest loc True + else do + logInfo "Redownload didn't happen" + pure Nothing + _ -> pure mres + GHLFilePath fp -> do + let source = resolvedAbsolute fp + mres <- tryParseYaml source + case mres of + Nothing -> do + prettyInfoL + [ flow "Could not find local global hints for" + , string (T.unpack $ RIO.textDisplay wc) + , "in" + , pretty source <> "." + ] + pure Nothing + _ -> do + liftIO $ copyFile source dest + prettyDebugL + [ flow "Installed global hints from" + , pretty source + ] + pure mres + inner2 fp = liftIO $ do + allGlobalHints <- Yaml.decodeFileThrow (toFilePath fp) + let globalHints = Map.lookup wc allGlobalHints + pure $ fmap (fmap unCabalString . unCabalStringMap) globalHints + tryParseYaml fp = do + eres <- tryAny (inner2 fp) + case eres of + Left e -> do + prettyError $ + "[S-912]" + <> line + <> flow "Error when parsing global hints:" + <> blankLine + <> string (displayException e) + pure Nothing + Right x -> pure x -- | Partition a map of global packages with its versions into a Set of replaced -- packages and its dependencies and a map of remaining (untouched) packages.