hackport 0.8.0.0 → 0.8.1.0
raw patch · 10 files changed
+157/−77 lines, 10 files
Files
- hackage-security/.git +1/−0
- hackport.cabal +2/−2
- src/Merge.hs +46/−38
- src/Portage/GHCCore.hs +10/−10
- src/Portage/Metadata.hs +65/−19
- src/Portage/Metadata/RemoteId.hs +4/−4
- src/Status.hs +4/−3
- src/Util.hs +5/−0
- tests/spec/Portage/Metadata/RemoteIdSpec.hs +4/−0
- tests/spec/Portage/MetadataSpec.hs +16/−1
+ hackage-security/.git view
@@ -0,0 +1,1 @@+gitdir: ../.git/modules/hackage-security
hackport.cabal view
@@ -1,11 +1,11 @@ cabal-version: 3.0 name: hackport-version: 0.8.0.0+version: 0.8.1.0 license: GPL-3.0-or-later license-file: LICENSE author: Henning Günther, Duncan Coutts, Lennart Kolmodin maintainer: Gentoo Haskell team <haskell@gentoo.org>-copyright: Copyright 1999-2022 Gentoo Authors+copyright: Copyright 1999-2023 Gentoo Authors category: Distribution synopsis: Hackage and Portage integration tool homepage: https://github.com/gentoo-haskell/hackport#readme
src/Merge.hs view
@@ -6,6 +6,7 @@ Core functionality of the @merge@ command of @HackPort@. -} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} module Merge@@ -51,7 +52,7 @@ ) import System.Process import System.FilePath ((</>),(<.>))-import System.Exit+import System.Exit (ExitCode(ExitSuccess), exitSuccess) -- hackport import qualified AnsiColor as A@@ -64,7 +65,6 @@ import qualified Portage.PackageId as Portage import qualified Portage.Version as Portage import qualified Portage.Metadata as Portage-import qualified Portage.Metadata.RemoteId as Portage import qualified Portage.Overlay as Overlay import qualified Portage.Resolve as Portage import qualified Portage.Dependency as Portage@@ -490,14 +490,14 @@ -- | Write the ebuild (and sometimes a new @metadata.xml@) to its directory. mergeEbuild- :: WritesMetadata env+ :: forall env. WritesMetadata env => EM.EMeta -> FilePath -> E.EBuild -> [Cabal.PackageFlag] -> Env env ()-mergeEbuild existing_meta pkgdir ebuild flags- = ask >>= \(_, useHackageRemote -> useHackageRemoteId) -> do+mergeEbuild existing_meta pkgdir ebuild flags = do+ cmdEnv :: env <- askEnv let edir = pkgdir elocal = E.name ebuild ++"-"++ E.version ebuild <.> "ebuild"@@ -505,36 +505,36 @@ emeta = "metadata.xml" mpath = edir </> emeta yet_meta <- liftIO $ doesFileExist mpath- -- If there is an existing @metadata.xml@, read it in as a 'T.Text'.- -- Otherwise return 'T.empty'. We only use this once more to directly- -- compare to @default_meta@ before writing it.- current_meta <- if yet_meta- then liftIO $ T.readFile mpath- else return T.empty- -- Either create an object of the 'Portage.Metadata' type from a valid @current_meta@,- -- or supply a default minimal metadata object. Note the difference to @current_meta@:- -- @current_meta@ is of type 'T.Text', @current_meta'@ is of type 'Portage.Metadata'.- let current_meta' = fromMaybe (Portage.minimalMetadata useHackageRemoteId ebuild)- (Portage.parseMetadataXML current_meta)- hackageRemoteId =- if useHackageRemoteId- then S.singleton $ Portage.RemoteIdHackage $ E.hackage_name ebuild- else S.empty- -- Create the @metadata.xml@ string, adding new USE flags (if any) to those of- -- the existing @metadata.xml@. If an existing flag has a new and old description,- -- the new one takes precedence.- default_meta = Portage.printMetadata $- current_meta' <> mempty- { Portage.metadataUseFlags = Merge.metaFlags flags- , Portage.metadataRemoteIds =- Portage.matchURIs (E.sourceURIs ebuild) <> hackageRemoteId- }++ -- Get the current metadata.xml contents if it exists. If it does, try to+ -- parse it as well.+ currentMetaState :: Maybe (T.Text, Portage.Metadata) <-+ if yet_meta+ then do+ t <- liftIO $ T.readFile mpath+ case Portage.parseMetadataXML t of+ Just m -> pure $ Just (t, m)+ Nothing -> die "Could not parse the existing metadata.xml"+ else pure Nothing++ let+ -- Break the currentMetaState into it's individual components+ currentMetaText = fst <$> currentMetaState+ currentMeta = snd <$> currentMetaState++ -- Update the current metadata with info from 'ebuild' and 'flags'. If+ -- the current metadata doesn't exist, this will build off a template.+ updatedMeta = Portage.updateMetadata cmdEnv ebuild flags currentMeta++ -- Write the updated meta file to a Text buffer+ updatedMetaText = Portage.printMetadata updatedMeta+ -- Create a 'Map.Map' of USE flags with updated descriptions. new_flags = Map.differenceWith (\new old -> if (new /= old) then Just $ old ++ A.bold (" -> " ++ new) else Nothing) (Merge.metaFlags flags)- (Portage.metadataUseFlags current_meta')+ (Portage.metadataUseFlags updatedMeta) liftIO $ createDirectoryIfMissing True edir now <- liftIO $ TC.getCurrentTime@@ -557,13 +557,21 @@ notice $ "Writing " ++ elocal length s_ebuild' `seq` liftIO (T.writeFile epath (T.pack s_ebuild')) - when (current_meta /= default_meta) $ do- when (current_meta /= T.empty) $ do- notice $ A.bold $ "Default and current " ++ emeta ++ " differ."- if (new_flags /= Map.empty)- then notice $ "New or updated USE flags:\n" ++- unlines (Portage.prettyPrintFlagsHuman (Portage.stripGlobalUseFlags new_flags))- else notice "No new USE flags."+ metadataNeedsWriting <- + case currentMetaText of+ Just t+ -- If the metadata.xml exists and our updated version is identical,+ -- we don't need to write it+ | t == updatedMetaText -> pure False+ | otherwise -> do+ notice $ A.bold $ "Default and current " ++ emeta ++ " differ."+ if (new_flags /= Map.empty)+ then notice $ "New or updated USE flags:\n" +++ unlines (Portage.prettyPrintFlagsHuman (Portage.stripGlobalUseFlags new_flags))+ else notice "No new USE flags."+ pure True+ Nothing -> pure True + when metadataNeedsWriting $ do notice $ "Writing " ++ emeta- liftIO $ T.writeFile mpath default_meta+ liftIO $ T.writeFile mpath updatedMetaText
src/Portage/GHCCore.hs view
@@ -60,7 +60,7 @@ , ([8,8,4], Cabal.mkVersion [3,0,1,0]) , ([8,10,1], Cabal.mkVersion [3,2,0,0]) , ([8,10,4], Cabal.mkVersion [3,2,1,0])- , ([9,0,2], Cabal.mkVersion [3,4,1,0])+ , ([9,0,2], Cabal.mkVersion [3,4,1,0]) ] platform :: Platform@@ -200,7 +200,7 @@ , p "mtl" [2,2,2] -- used by exceptions , p "parsec" [3,1,14,0] -- used by exceptions , p "pretty" [1,1,3,6]--- , p "process" [1,6,13,2] package is upgradeable+ , p "process" [1,6,13,2] -- , p "stm" [2,5,0,0] package is upgradeable(?) , p "template-haskell" [2,17,0,0] -- used by libghc , p "terminfo" [0,4,1,5] -- used by libghc@@ -235,7 +235,7 @@ , p "mtl" [2,2,2] -- used by exceptions in ghc-9.0.2 , p "parsec" [3,1,14,0] -- used by exceptions in ghc-9.0.2 , p "pretty" [1,1,3,6]--- , p "process" [1,6,9,0] package is upgradeable+ , p "process" [1,6,9,0] -- , p "stm" [2,5,0,0] package is upgradeable(?) , p "template-haskell" [2,16,0,0] -- used by libghc , p "terminfo" [0,4,1,4] -- used by libghc in ghc-9.0.2@@ -270,7 +270,7 @@ , p "mtl" [2,2,2] -- used by libghc in ghc-9.0.2 , p "parsec" [3,1,14,0] -- used by libghc in ghc-9.0.2 , p "pretty" [1,1,3,6]--- , p "process" [1,6,8,2] package is upgradeable+ , p "process" [1,6,8,2] -- , p "stm" [2,5,0,0] package is upgradeable(?) , p "template-haskell" [2,16,0,0] -- used by libghc , p "terminfo" [0,4,1,4] -- used by libghc in ghc-9.0.2@@ -303,7 +303,7 @@ , p "mtl" [2,2,2] -- used by exceptions in ghc-9.0.2 , p "parsec" [3,1,14,0] -- used by exceptions in ghc-9.0.2 , p "pretty" [1,1,3,6]--- , p "process" [1,6,9,0] package is upgradeable+ , p "process" [1,6,9,0] -- , p "stm" [2,5,0,0] package is upgradeable(?) , p "template-haskell" [2,15,0,0] -- used by libghc , p "terminfo" [0,4,1,4] -- used by libghc in ghc-9.0.2@@ -336,7 +336,7 @@ , p "mtl" [2,2,2] -- used by exceptions in ghc-9.0.2 , p "parsec" [3,1,14,0] -- used by exceptions in ghc-9.0.2 , p "pretty" [1,1,3,6]--- , p "process" [1,6,8,0] package is upgradeable+ , p "process" [1,6,8,0] -- , p "stm" [2,5,0,0] package is upgradeable(?) , p "template-haskell" [2,15,0,0] -- used by libghc , p "terminfo" [0,4,1,4] -- used by libghc in ghc-9.0.2@@ -369,7 +369,7 @@ , p "mtl" [2,2,2] -- used by exceptions in ghc-9.0.2 , p "parsec" [3,1,14,0] -- used by exceptions in ghc-9.0.2 , p "pretty" [1,1,3,6]--- , p "process" [1,6,5,1] package is upgradeable+ , p "process" [1,6,5,1] -- , p "stm" [2,5,0,0] package is upgradeable(?) , p "template-haskell" [2,15,0,0] -- used by libghc , p "terminfo" [0,4,1,4] -- used by libghc in ghc-9.0.2@@ -402,7 +402,7 @@ , p "mtl" [2,2,2] -- used by exceptions in ghc-9.0.2 , p "parsec" [3,1,13,0] -- used by exceptions in ghc-9.0.2 , p "pretty" [1,1,3,6]--- , p "process" [1,6,5,0] package is upgradeable+ , p "process" [1,6,5,0] -- , p "stm" [2,5,0,0] package is upgradeable(?) , p "template-haskell" [2,14,0,0] -- used by libghc , p "terminfo" [0,4,1,2] -- used by libghc in ghc-9.0.2@@ -435,7 +435,7 @@ , p "mtl" [2,2,2] -- used by exceptions in ghc-9.0.2 , p "parsec" [3,1,13,0] -- used by exceptions in ghc-9.0.2 , p "pretty" [1,1,3,6]--- , p "process" [1,6,3,0] package is upgradeable+ , p "process" [1,6,3,0] -- , p "stm" [2,5,0,0] package is upgradeable(?) , p "template-haskell" [2,14,0,0] -- used by libghc , p "terminfo" [0,4,1,2] -- used by libghc in ghc-9.0.2@@ -468,7 +468,7 @@ , p "mtl" [2,2,2] -- used by exceptions in ghc-9.0.2 , p "parsec" [3,1,13,0] -- used by exceptions in ghc-9.0.2 , p "pretty" [1,1,3,6]--- , p "process" [1,6,3,0] package is upgradeable+ , p "process" [1,6,3,0] -- , p "stm" [2,4,5,0] package is upgradeable(?) , p "template-haskell" [2,13,0,0] -- used by libghc , p "terminfo" [0,4,1,1] -- used by libghc in ghc-9.0.2
src/Portage/Metadata.hs view
@@ -8,6 +8,7 @@ module Portage.Metadata ( Metadata(..) , UseFlags+ , updateMetadata , readMetadataFile , parseMetadataXML , stripGlobalUseFlags -- exported for hspec@@ -19,14 +20,16 @@ import qualified AnsiColor as A -import Control.Monad+import Data.Maybe (fromMaybe) import qualified Data.Map.Strict as Map import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.IO as T +import qualified Distribution.PackageDescription as Cabal import Text.XML.Light +import Merge.Utils as Merge import Portage.EBuild as EBuild import Portage.Metadata.RemoteId @@ -49,6 +52,49 @@ instance Monoid Metadata where mempty = Metadata mempty mempty mempty ++-- | Update any existing metadata with changes to USE flags and remote-ids. If+-- the current metadata doesn't exist, it will modify a template created by+-- 'minimalMetadata'.+updateMetadata :: WritesMetadata env + => env -- ^ Local environment carried by 'Env'+ -> EBuild.EBuild -- ^ 'EBuild.EBuild' representation we are building metadata for+ -> [Cabal.PackageFlag] -- ^ cabal package flags+ -> Maybe Metadata -- ^ Current metadata, if any+ -> Metadata+updateMetadata cmdEnv ebuild flags currentMeta =+ let+ -- Supply a default minimal metadata object if current metadata doesn't exist.+ currentMeta' = fromMaybe+ (minimalMetadata (useHackageRemote cmdEnv) ebuild)+ currentMeta++ -- The remote-id for hackage is always added, unless 'useHackageRemote' returns False+ -- (generally disabled on the command line with the --not-on-hackage flag for the+ -- make-ebuild command).+ hackageRemoteId =+ if useHackageRemote cmdEnv+ then S.singleton $ RemoteIdHackage $ EBuild.hackage_name ebuild+ else S.empty++ -- Sometimes the .cabal file will explicitly list source repos+ sourceRemoteIds =+ let r = matchURIs (EBuild.sourceURIs ebuild)+ in + if S.null r+ -- If the list of source remote-ids is empty, we fall back to using the homepage+ then matchURIs [EBuild.homepage ebuild]+ else r++ -- Create the new metadata, adding new USE flags (if any) to those of the+ -- existing metadata. If an existing flag has a new and old description,+ -- the new one takes precedence.+ in currentMeta' <> mempty+ { metadataUseFlags = Merge.metaFlags flags+ , metadataRemoteIds =+ hackageRemoteId <> sourceRemoteIds+ }+ -- | Maybe return a 'Metadata' from a 'T.Text'. -- -- Trying to parse an empty 'T.Text' should return 'Nothing':@@ -56,32 +102,32 @@ -- >>> parseMetadataXML T.empty -- Nothing parseMetadataXML :: T.Text -> Maybe Metadata-parseMetadataXML = parseMetadata <=< parseXMLDoc+parseMetadataXML = fmap parseMetadata . parseXMLDoc -- | Apply 'parseMetadataXML' to a 'FilePath'.-readMetadataFile :: FilePath -> IO (Maybe Metadata)-readMetadataFile fp = parseMetadataXML <$> T.readFile fp+readMetadataFile :: MonadIO m => FilePath -> m (Maybe Metadata)+readMetadataFile = liftIO . fmap parseMetadataXML . T.readFile -- | Extract the maintainer email and USE flags from a supplied XML 'Element'. -- -- If we're parsing a blank 'Element' or otherwise empty @metadata.xml@: -- >>> parseMetadata blank_element--- Just (Metadata {metadataEmails = [], metadataUseFlags = fromList [], metadataRemoteIds = fromList []})-parseMetadata :: Element -> Maybe Metadata+-- Metadata {metadataEmails = [], metadataUseFlags = fromList [], metadataRemoteIds = fromList []}+parseMetadata :: Element -> Metadata parseMetadata xml =- return Metadata { metadataEmails = strContent <$> findElements (unqual "email") xml- , metadataUseFlags =- -- find the flag name- let x = findElement (unqual "use") xml- y = onlyElems $ concatMap elContent x- z = attrVal <$> concatMap elAttribs y- -- find the flag description- a = concatMap elContent y- b = cdData <$> onlyText a- in Map.fromList $ zip z b- -- TODO: Read remote-ids from existing metadata.xml- , metadataRemoteIds = S.empty- }+ Metadata { metadataEmails = strContent <$> findElements (unqual "email") xml+ , metadataUseFlags =+ -- find the flag name+ let x = findElement (unqual "use") xml+ y = onlyElems $ concatMap elContent x+ z = attrVal <$> concatMap elAttribs y+ -- find the flag description+ a = concatMap elContent y+ b = cdData <$> onlyText a+ in Map.fromList $ zip z b+ -- TODO: Read remote-ids from existing metadata.xml+ , metadataRemoteIds = S.empty+ } -- | Remove global @USE@ flags from the flags 'Map.Map', as these should not be -- within the local @metadata.xml@. For now, this is manually specified rather than
src/Portage/Metadata/RemoteId.hs view
@@ -55,7 +55,7 @@ import qualified Data.List as L import Data.Maybe (catMaybes, mapMaybe) import qualified Data.Set as S-import Network.URI (URI(..), URIAuth(..), parseAbsoluteURI)+import Network.URI (URI(..), URIAuth(..), parseURI) import System.FilePath.Posix import Text.Parsec import Text.Parsec.String@@ -360,7 +360,7 @@ -- | Run a specified 'URIParser' with a string ----- Internally, uses 'parseAbsoluteURI' to create a 'URI', and then uses each+-- Internally, uses 'parseURI' to create a 'URI', and then uses each -- parser specified in 'URIParser' on a specific part of the uri. These -- intermediate results are coalesced with the supplied 'mkRemoteId'. runUriParser@@ -372,7 +372,7 @@ go :: Parser (Either ParseError RemoteId) go = do cs <- allChars- case parseAbsoluteURI cs of+ case parseURI cs of Just (URI scheme (Just (URIAuth user regname port)) path query fragment) -> pure $ mkRemoteId <$> parseIt schemeParser scheme@@ -382,7 +382,7 @@ <*> parseIt pathParser path <*> parseIt queryParser query <*> parseIt fragmentParser fragment- _ -> fail $ "Could not parse as an absolute URI: " ++ show cs+ _ -> fail $ "Could not parse as a URI: " ++ show cs parseIt :: Parser a -> String -> Either ParseError a parseIt p = parse p ""
src/Status.hs view
@@ -29,7 +29,7 @@ -- cabal import qualified Distribution.Package as Cabal (pkgName)-import qualified Distribution.Simple.Utils as Cabal (die', equating)+import qualified Distribution.Simple.Utils as Cabal (equating) import Distribution.Pretty (prettyShow) import Distribution.Parsec (simpleParsec) @@ -43,6 +43,7 @@ import Status.Types import Hackport.Env import Hackport.Util+import Util @@ -116,14 +117,14 @@ runStatus :: CabalInstall.RepoContext -> Env StatusEnv () runStatus repoContext =- ask >>= \(GlobalEnv verbosity _ _, StatusEnv direction pkgs) -> do+ ask >>= \(_, StatusEnv direction pkgs) -> do let pkgFilter = case direction of OverlayToPortage -> toPortageFilter PortagePlusOverlay -> id HackageToOverlay -> fromHackageFilter pkgs' <- forM pkgs $ \p -> case simpleParsec p of- Nothing -> liftIO $ Cabal.die' verbosity ("Could not parse package name: " ++ p ++ ". Format cat/pkg")+ Nothing -> die ("Could not parse package name: " ++ p ++ ". Format cat/pkg") Just pn -> return pn tree0 <- status repoContext let tree = pkgFilter tree0
src/Util.hs view
@@ -11,6 +11,7 @@ , debug , notice , info+ , die ) where import System.IO@@ -43,3 +44,7 @@ info :: (HasGlobalEnv m, MonadIO m) => String -> m () info s = askGlobalEnv >>= \(GlobalEnv v _ _) -> liftIO $ Cabal.info v s++-- | Terminate with an error message+die :: (HasGlobalEnv m, MonadIO m) => String -> m a+die s = askGlobalEnv >>= \(GlobalEnv v _ _) -> liftIO $ Cabal.die' v s
tests/spec/Portage/Metadata/RemoteIdSpec.hs view
@@ -95,4 +95,8 @@ "https://github.com/dhall-lang/dhall-haskell/tree/master/dhall-toml" githubParser (RemoteIdGithub "dhall-lang" "dhall-haskell")+ , Example+ "https://github.com/gentoo-haskell/hackport#readme"+ githubParser+ (RemoteIdGithub "gentoo-haskell" "hackport") ]
tests/spec/Portage/MetadataSpec.hs view
@@ -10,6 +10,7 @@ import qualified Portage.EBuild as E import Portage.Metadata import Portage.Metadata.RemoteId+import qualified Hackport.Env as Env spec :: Spec spec = do@@ -128,7 +129,7 @@ in printMetadata meta `shouldBe` correctMetadata context "when writing a minimal metadata.xml with global USE flags" $ do it "should not leave an empty <use> element" $ do- let meta = minimalMetadata True E.ebuildTemplate <> mempty+ let meta = (minimalMetadata True E.ebuildTemplate) { metadataUseFlags = Map.fromList [("debug","it debugs") ,("examples","some examples")@@ -150,3 +151,17 @@ , "</pkgmetadata>" ] in printMetadata meta `shouldBe` correctMetadata++ describe "updateMetadata" $ do+ it "should default to minimalMetadata" $ do+ let cmdEnv = Env.MergeEnv Nothing "hackport"+ ebuild = E.ebuildTemplate+ in updateMetadata cmdEnv ebuild [] Nothing `shouldBe` minimalMetadata True ebuild++ it "should fall back to the homepage for remote-id" $ do+ let cmdEnv = Env.MergeEnv Nothing "hackport"+ ebuild = E.ebuildTemplate { E.homepage = "https://github.com/gentoo-haskell/hackport#readme" }+ correctRemoteId = RemoteIdGithub "gentoo-haskell" "hackport"+ mkCorrectMeta (Metadata e f r) = Metadata e f (S.insert correctRemoteId r)+ in updateMetadata cmdEnv ebuild [] Nothing + `shouldBe` mkCorrectMeta (minimalMetadata True E.ebuildTemplate)