{-|
Module : Portage.Metadata
License : GPL-3+
Maintainer : haskell@gentoo.org
Functions and types related to @metadata.xml@ processing
-}
module Portage.Metadata
( Metadata(..)
, UseFlags
, updateMetadata
, readMetadataFile
, parseMetadataXML
, stripGlobalUseFlags -- exported for hspec
, prettyPrintFlags -- exported for hspec
, prettyPrintFlagsHuman
, printMetadata
, minimalMetadata
) where
import qualified AnsiColor as A
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
import Hackport.Env
type UseFlags = Map.Map String String
-- | A data type for the Gentoo-specific @metadata.xml@ file.
-- Currently defines functions for the maintainer email and
-- USE flags and their descriptions.
data Metadata = Metadata
{ metadataEmails :: [String] -- ^ This should /always/ be [\"haskell@gentoo.org\"].
, metadataUseFlags :: UseFlags -- ^ Only /active/ USE flags, if any.
, metadataRemoteIds :: S.Set RemoteId
} deriving (Eq, Show, Ord)
instance Semigroup Metadata where
Metadata e1 u1 r1 <> Metadata e2 u2 r2 = Metadata (e1<>e2) (u1<>u2) (r1<>r2)
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 = matchURIs (EBuild.sourceURIs ebuild)
-- Try to extract a remote id using the homepage
<> matchURIs [EBuild.homepage ebuild]
-- 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':
--
-- >>> parseMetadataXML T.empty
-- Nothing
parseMetadataXML :: T.Text -> Maybe Metadata
parseMetadataXML = fmap parseMetadata . parseXMLDoc
-- | Apply 'parseMetadataXML' to a 'FilePath'.
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
-- Metadata {metadataEmails = [], metadataUseFlags = fromList [], metadataRemoteIds = fromList []}
parseMetadata :: Element -> Metadata
parseMetadata xml =
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
-- parsing @use.desc@.
stripGlobalUseFlags :: UseFlags -> UseFlags
stripGlobalUseFlags m = foldr Map.delete m globals
where
globals = [ "debug"
, "examples"
, "static"
, "test"
]
-- | Pretty print as valid XML a list of flags and their descriptions
-- from a given 'Map.Map'. This wraps the flags in "" and is
-- meant to be passed to 'unlines'. If the Map is empty, it will return no
-- output.
prettyPrintFlags :: UseFlags -> [String]
prettyPrintFlags m
| Map.null m = []
| otherwise = ["\t"]
where
go = printFlag <$> Map.toAscList m
printFlag (n, d) =
"\t\t" ++
showElement
(add_attr
(Attr (blank_name { qName = "name" }) n)
(unode "flag" d)
)
-- | Pretty print a human-readable list of flags and their descriptions
-- from a given 'Map.Map'.
prettyPrintFlagsHuman :: UseFlags -> [String]
prettyPrintFlagsHuman m
= (\(n,d) -> A.bold (n ++ ": ") ++ (unwords . lines $ d))
<$> Map.toAscList m
-- | A minimal metadata for use as a fallback value.
minimalMetadata :: UseHackageRemote -> EBuild.EBuild -> Metadata
minimalMetadata useHackage ebuild =
mempty
{ metadataEmails = ["haskell@gentoo.org"]
, metadataRemoteIds =
if useHackage
then S.singleton $ RemoteIdHackage $ EBuild.hackage_name ebuild
else S.empty
}
-- don't use Text.XML.Light as we like our own pretty printer
-- | Pretty print the @metadata.xml@ string.
printMetadata :: Metadata -> T.Text
printMetadata (Metadata _ flags rids) = T.pack $
unlines $
[ ""
, ""
, ""
, "\t"
, "\t\thaskell@gentoo.org"
, "\t\tGentoo Haskell"
, "\t"
]
++ prettyPrintFlags (stripGlobalUseFlags flags)
++ prettyPrintRemoteIds rids
++
[ ""
]