diff --git a/hackage-security/.git b/hackage-security/.git new file mode 100644 --- /dev/null +++ b/hackage-security/.git @@ -0,0 +1,1 @@ +gitdir: ../.git/modules/hackage-security diff --git a/hackport.cabal b/hackport.cabal --- a/hackport.cabal +++ b/hackport.cabal @@ -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 -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 diff --git a/src/Merge.hs b/src/Merge.hs --- a/src/Merge.hs +++ b/src/Merge.hs @@ -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 diff --git a/src/Portage/GHCCore.hs b/src/Portage/GHCCore.hs --- a/src/Portage/GHCCore.hs +++ b/src/Portage/GHCCore.hs @@ -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 diff --git a/src/Portage/Metadata.hs b/src/Portage/Metadata.hs --- a/src/Portage/Metadata.hs +++ b/src/Portage/Metadata.hs @@ -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 diff --git a/src/Portage/Metadata/RemoteId.hs b/src/Portage/Metadata/RemoteId.hs --- a/src/Portage/Metadata/RemoteId.hs +++ b/src/Portage/Metadata/RemoteId.hs @@ -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 "" diff --git a/src/Status.hs b/src/Status.hs --- a/src/Status.hs +++ b/src/Status.hs @@ -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 diff --git a/src/Util.hs b/src/Util.hs --- a/src/Util.hs +++ b/src/Util.hs @@ -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 diff --git a/tests/spec/Portage/Metadata/RemoteIdSpec.hs b/tests/spec/Portage/Metadata/RemoteIdSpec.hs --- a/tests/spec/Portage/Metadata/RemoteIdSpec.hs +++ b/tests/spec/Portage/Metadata/RemoteIdSpec.hs @@ -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") ] diff --git a/tests/spec/Portage/MetadataSpec.hs b/tests/spec/Portage/MetadataSpec.hs --- a/tests/spec/Portage/MetadataSpec.hs +++ b/tests/spec/Portage/MetadataSpec.hs @@ -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 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 @@ , "" ] 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)