hackport 0.6.6 → 0.6.7
raw patch · 22 files changed
+356/−187 lines, 22 filesdep +paralleldep ~base16-bytestringdep ~network-uri
Dependencies added: parallel
Dependency ranges changed: base16-bytestring, network-uri
Files
- Main.hs +1/−11
- Merge.hs +79/−36
- Merge/Dependencies.hs +10/−9
- Merge/Utils.hs +42/−2
- Portage/Cabal.hs +5/−4
- Portage/Dependency/Builder.hs +1/−3
- Portage/Dependency/Types.hs +35/−2
- Portage/EBuild.hs +30/−8
- Portage/Host.hs +4/−7
- Portage/Metadata.hs +47/−28
- Portage/Overlay.hs +0/−2
- Portage/PackageId.hs +10/−0
- Portage/Use.hs +12/−0
- Portage/Version.hs +12/−0
- Status.hs +8/−1
- hackport.cabal +7/−5
- tests/Merge/UtilsSpec.hs +14/−0
- tests/Merge/UtilsSpec.hs~ +0/−53
- tests/Portage/EBuildSpec.hs +4/−1
- tests/Portage/MetadataSpec.hs +31/−11
- tests/Portage/VersionSpec.hs +3/−3
- tests/QuickCheck/Instances.hs +1/−1
Main.hs view
@@ -5,8 +5,6 @@ import Control.Monad import Data.Maybe import Data.List-import Data.Monoid- ( Monoid(..) ) import qualified Data.Semigroup as S -- cabal@@ -63,13 +61,11 @@ listVerbosity :: Flag Verbosity } -#if MIN_VERSION_base(4,9,0) instance S.Semigroup ListFlags where a <> b = ListFlags { listVerbosity = combine listVerbosity } where combine field = field a S.<> field b-#endif instance Monoid ListFlags where mempty = ListFlags {@@ -136,21 +132,19 @@ , makeEbuildCabalFlags :: Flag (Maybe String) } -#if MIN_VERSION_base(4,9,0) instance S.Semigroup MakeEbuildFlags where a <> b = MakeEbuildFlags { makeEbuildVerbosity = combine makeEbuildVerbosity , makeEbuildCabalFlags = makeEbuildCabalFlags b } where combine field = field a S.<> field b-#endif instance Monoid MakeEbuildFlags where mempty = MakeEbuildFlags { makeEbuildVerbosity = mempty , makeEbuildCabalFlags = mempty }-#if MIN_VERSION_base(4,9,0)+#if !MIN_VERSION_base(4,11,0) mappend a b = MakeEbuildFlags { makeEbuildVerbosity = combine makeEbuildVerbosity , makeEbuildCabalFlags = makeEbuildCabalFlags b@@ -208,13 +202,11 @@ updateVerbosity :: Flag Verbosity } -#if MIN_VERSION_base(4,9,0) instance S.Semigroup UpdateFlags where a <> b = UpdateFlags { updateVerbosity = combine updateVerbosity } where combine field = field a S.<> field b-#endif instance Monoid UpdateFlags where mempty = UpdateFlags {@@ -322,14 +314,12 @@ , mergeCabalFlags :: Flag (Maybe String) } -#if MIN_VERSION_base(4,9,0) instance S.Semigroup MergeFlags where a <> b = MergeFlags { mergeVerbosity = combine mergeVerbosity , mergeCabalFlags = mergeCabalFlags b } where combine field = field a S.<> field b-#endif instance Monoid MergeFlags where mempty = MergeFlags {
Merge.hs view
@@ -10,13 +10,14 @@ , mergeGenericPackageDescription ) where -import Control.Monad-import Control.Exception+import Control.Concurrent.Async+import Control.Monad+import Control.Exception import qualified Data.Text as T import qualified Data.Text.IO as T-import Data.Function (on)+import Data.Function (on) import qualified Data.Map.Strict as Map-import Data.Maybe+import Data.Maybe import qualified Data.List as L import qualified Data.Set as S import qualified Data.Time.Clock as TC@@ -29,31 +30,33 @@ import qualified Distribution.Solver.Types.SourcePackage as CabalInstall import qualified Distribution.Solver.Types.PackageIndex as CabalInstall -import Distribution.Pretty (prettyShow)-import Distribution.Verbosity-import Distribution.Simple.Utils+import Distribution.Pretty (prettyShow)+import Distribution.Verbosity+import Distribution.Simple.Utils -- cabal-install-import Distribution.Client.IndexUtils ( getSourcePackages )+import Distribution.Client.IndexUtils ( getSourcePackages ) import qualified Distribution.Client.GlobalFlags as CabalInstall-import Distribution.Client.Types+import Distribution.Client.Types -- others+import Control.Parallel.Strategies import qualified Data.List.Split as DLS-import System.Directory ( getCurrentDirectory+import System.Directory ( getCurrentDirectory , setCurrentDirectory , createDirectoryIfMissing , doesFileExist , listDirectory )-import System.Process (system)-import System.FilePath ((</>),(<.>))-import System.Exit+import System.Process+import System.FilePath ((</>),(<.>))+import System.Exit +-- hackport import qualified AnsiColor as A import qualified Cabal2Ebuild as C2E import qualified Portage.EBuild as E import qualified Portage.EMeta as EM-import Error as E+import Error as E import qualified Portage.Cabal as Portage import qualified Portage.PackageId as Portage@@ -251,6 +254,7 @@ case lookup cfn cf_to_iuse_rename of Nothing -> Merge.mangle_iuse cfn Just ein -> ein+ -- key idea is to generate all possible list of flags deps1 :: [(CabalFlags, Merge.EDep)] deps1 = [ ( f `updateFa` Cabal.unFlagAssignment fr@@ -269,7 +273,7 @@ -- TODO: drop ghc libraries from tests depends as well -- (see deepseq in hackport-0.3.5 as an example) , let pkgDesc_filtered_bdeps = Merge.RetroPackageDescription pkgDesc1 ad- ]+ ] `using` parList rdeepseq where updateFa :: CabalFlags -> CabalFlags -> CabalFlags updateFa [] _ = []@@ -341,6 +345,18 @@ cabal_to_emerge_dep :: Merge.RetroPackageDescription -> Merge.EDep cabal_to_emerge_dep cabal_pkg = Merge.resolveDependencies overlay cabal_pkg compiler_info ghc_packages merged_cabal_pkg_name + -- When there are lots of package flags, computation of every possible flag combination+ -- can take a while (e.g., 12 package flags = 2^12 possible flag combinations).+ -- Warn the user about this if there are at least 12 package flags. 'cabal_flag_descs'+ -- is usually an overestimation since it includes flags that hackport will strip out,+ -- but using it instead of 'active_flag_descs' avoids forcing the very computation we+ -- are trying to warn the user about.+ when (length cabal_flag_descs >= 12) $+ notice verbosity $ "There are up to " +++ A.bold (show (2^(length cabal_flag_descs) :: Int)) +++ " possible flag combinations.\n" +++ A.inColor A.Yellow True A.Default "This may take a while."+ debug verbosity $ "buildDepends pkgDesc0 raw: " ++ Cabal.showPackageDescription pkgDesc0 debug verbosity $ "buildDepends pkgDesc0: " ++ show (map prettyShow (Merge.exeAndLibDeps pkgDesc0)) debug verbosity $ "buildDepends pkgDesc: " ++ show (map prettyShow (Merge.buildDepends pkgDesc))@@ -396,29 +412,53 @@ Just ucf -> (\e -> e { E.used_options = E.used_options e ++ [("flags", ucf)] })) $ C2E.cabal2ebuild cat (Merge.packageDescription pkgDesc) - mergeEbuild verbosity existing_meta pkgdir ebuild active_flag_descs+ let active_flag_descs_renamed =+ (\f -> f { Cabal.flagName = Cabal.mkFlagName . cfn_to_iuse . Cabal.unFlagName+ . Cabal.flagName $ f }) <$> active_flag_descs+ iuse_flag_descs <- Merge.dropIfUseExpands active_flag_descs_renamed+ mergeEbuild verbosity existing_meta pkgdir ebuild iuse_flag_descs+ when fetch $ do let cabal_pkgId = Cabal.packageId (Merge.packageDescription pkgDesc) norm_pkgName = Cabal.packageName (Portage.normalizeCabalPackageId cabal_pkgId) fetchDigestAndCheck verbosity (overlayPath </> prettyShow cat </> prettyShow norm_pkgName)+ $ Portage.fromCabalPackageId cat cabal_pkgId --- | Run various @repoman@ commands in the directory of the newly-generated ebuild.+-- | Run @ebuild@, @pkgcheck@ and @repoman@ commands in the directory of the+-- newly-generated ebuild.+-- -- This will ensure well-formed ebuilds and @metadata.xml@, and will update (if possible) -- the @Manifest@ file.+--+-- @pkgcheck@ and @repoman@ will run concurrently. fetchDigestAndCheck :: Verbosity -> FilePath -- ^ directory of ebuild+ -> Portage.PackageId -- ^ newest ebuild -> IO ()-fetchDigestAndCheck verbosity ebuildDir =- withWorkingDirectory ebuildDir $ do- notice verbosity "Recalculating digests (repoman manifest)..."- rm <- system "repoman manifest"- when (rm /= ExitSuccess) $- notice verbosity "repoman manifest failed horribly. Do something about it!"- rf <- system "repoman full --include-dev"- when (rf /= ExitSuccess) $- notice verbosity "repoman full --include-dev found an error. Do something about it!"- return ()+fetchDigestAndCheck verbosity ebuildDir pkgId =+ let ebuild = prettyShow (Portage.cabalPkgName . Portage.packageId $ pkgId)+ ++ "-" ++ prettyShow (Portage.pkgVersion pkgId) <.> "ebuild"+ in withWorkingDirectory ebuildDir $ do+ notice verbosity "Recalculating digests..."+ emEx <- system $ "ebuild " ++ ebuild ++ " manifest > /dev/null 2>&1"+ when (emEx /= ExitSuccess) $+ notice verbosity "ebuild manifest failed horribly. Do something about it!" + notice verbosity $ "Running " ++ A.bold "repoman full --include-dev " +++ "and " ++ A.bold "pkgcheck scan" ++ "..."++ (rfEx,(psEx,psOut,_)) <- system "repoman full --include-dev"+ `concurrently`+ readCreateProcessWithExitCode (shell "pkgcheck scan --color True") ""+ + when (rfEx /= ExitSuccess) $+ notice verbosity "repoman full --include-dev found an error. Do something about it!"+ when (psEx /= ExitSuccess) $ -- this should never be true, even with QA issues.+ notice verbosity $ A.inColor A.Red True A.Default "pkgcheck scan failed."+ notice verbosity psOut++ return ()+ withWorkingDirectory :: FilePath -> IO a -> IO a withWorkingDirectory newDir action = do oldDir <- getCurrentDirectory@@ -450,7 +490,11 @@ -- 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.makeDefaultMetadata (E.long_desc ebuild)+ default_meta = Portage.makeDefaultMetadata+ -- Ensure that the long description does not equal the+ -- ebuild description, which fails Gentoo QA.+ (if E.long_desc ebuild == E.description ebuild+ then "" else E.long_desc ebuild) $ Merge.metaFlags flags `Map.union` Portage.metadataUseFlags current_meta' -- Create a 'Map.Map' of USE flags with updated descriptions.@@ -463,17 +507,15 @@ createDirectoryIfMissing True edir now <- TC.getCurrentTime - let (existing_keywords, existing_license, existing_description) = (EM.keywords existing_meta, EM.license existing_meta, EM.description existing_meta)+ let (existing_keywords, existing_license) = (EM.keywords existing_meta, EM.license existing_meta) new_keywords = maybe (E.keywords ebuild) (map Merge.to_unstable) existing_keywords new_license = either (\err -> maybe (Left err) Right existing_license) Right (E.license ebuild)- new_description = maybe (E.description ebuild) id existing_description ebuild' = ebuild { E.keywords = new_keywords , E.license = new_license- , E.description = new_description } s_ebuild' = E.showEBuild now ebuild' @@ -484,11 +526,12 @@ length s_ebuild' `seq` T.writeFile epath (T.pack s_ebuild') when (current_meta /= default_meta) $ do- notice verbosity $ A.bold $ "Default and current " ++ emeta ++ " differ."- if (new_flags /= Map.empty)- then notice verbosity $ "New or updated USE flags:\n" ++- (unlines $ Portage.prettyPrintFlagsHuman new_flags)- else notice verbosity "No new USE flags."+ when (current_meta /= T.empty) $ do+ notice verbosity $ A.bold $ "Default and current " ++ emeta ++ " differ."+ if (new_flags /= Map.empty)+ then notice verbosity $ "New or updated USE flags:\n" +++ (unlines $ Portage.prettyPrintFlagsHuman new_flags)+ else notice verbosity "No new USE flags." notice verbosity $ "Writing " ++ emeta T.writeFile mpath default_meta
Merge/Dependencies.hs view
@@ -14,9 +14,13 @@ , resolveDependencies ) where -import Data.Maybe ( isJust, isNothing )-import Data.Monoid ( Monoid, mempty )+import Control.DeepSeq (NFData(..))+import Control.Parallel.Strategies+import Data.Maybe ( isJust, isNothing ) import qualified Data.List as L+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup (Semigroup(..))+#endif import qualified Data.Set as S import qualified Distribution.CabalSpecVersion as Cabal@@ -41,10 +45,6 @@ import Debug.Trace ( trace ) -#if MIN_VERSION_base(4,9,0)-import Data.Semigroup (Semigroup(..))-#endif- -- | Dependencies of an ebuild. data EDep = EDep {@@ -55,6 +55,9 @@ } deriving (Show, Eq, Ord) +instance NFData EDep where+ rnf (EDep rd rde d de) = rnf rd `seq` rnf rde `seq` rnf d `seq` rnf de+ -- | Cabal-1 style 'Cabal.PackageDescription', with a top-level 'buildDepends' function. data RetroPackageDescription = RetroPackageDescription { packageDescription :: Cabal.PackageDescription,@@ -73,7 +76,6 @@ concatMap (Cabal.targetBuildDepends . Cabal.libBuildInfo) (Cabal.allLibraries pkg) -#if MIN_VERSION_base(4,9,0) instance Semigroup EDep where (EDep rdepA rdep_eA depA dep_eA) <> (EDep rdepB rdep_eB depB dep_eB) = EDep { rdep = Portage.DependAllOf [rdepA, rdepB]@@ -81,7 +83,6 @@ , dep = Portage.DependAllOf [depA, depB] , dep_e = dep_eA `S.union` dep_eB }-#endif instance Monoid EDep where mempty = EDep@@ -175,7 +176,7 @@ add_profile = Portage.addDepUseFlag (Portage.mkQUse (Portage.Use "profile")) -- remove depends present in common section remove_raw_common = filter (\d -> not (Portage.dep_as_broad_as d raw_haskell_deps))- . map PN.normalize_depend+ . map PN.normalize_depend --------------------------------------------------------------- -- Custom-setup dependencies
Merge/Utils.hs view
@@ -13,14 +13,20 @@ , mangle_iuse , to_unstable , metaFlags+ , dropIfUseExpands+ -- hspec exports+ , dropIfUseExpand ) where import qualified Control.Monad as M-import Data.Maybe (mapMaybe)+import qualified Data.Char as C+import Data.Maybe (catMaybes, mapMaybe) import qualified Data.List as L import qualified Data.Map.Strict as Map+import qualified System.Directory as SD import qualified System.FilePath as SF-+import System.FilePath ((</>))+import System.Process (readCreateProcess, shell) import Error import qualified Portage.PackageId as Portage @@ -140,3 +146,37 @@ -- fromList [("foo","bar")] metaFlags :: [Cabal.PackageFlag] -> Map.Map String String metaFlags flags = Map.fromList $ zip (mangle_iuse . Cabal.unFlagName . Cabal.flagName <$> flags) (Cabal.flagDescription <$> flags)++-- | Return a list of @USE_EXPAND@s maintained by ::gentoo.+--+-- First, 'getUseExpands' runs @portageq@ to determine the 'FilePath' of the+-- directory containing valid @USE_EXPAND@s. If the 'FilePath' exists,+-- it drops the filename extensions to return a list of @USE_EXPAND@s+-- as Portage understands them. If the 'FilePath' does not exist, 'getUseExpands'+-- supplies a bare-bones list of @USE_EXPAND@s.+getUseExpands :: IO [String]+getUseExpands = do+ portDir <- readCreateProcess (shell "portageq get_repo_path / gentoo") ""+ let use_expands_dir = (L.dropWhileEnd C.isSpace portDir) </> "profiles" </> "desc"+ path_exists <- SD.doesPathExist use_expands_dir+ if path_exists+ then do use_expands_contents <- SD.listDirectory use_expands_dir+ return (SF.dropExtension <$> use_expands_contents)+ -- Provide some sensible defaults if hackport cannot find ::gentoo+ else let use_expands_contents = ["cpu_flags_arm","cpu_flags_ppc","cpu_flags_x86"]+ in return use_expands_contents++-- | Return a 'Cabal.PackageFlag' if it is not a @USE_EXPAND@.+--+-- If the 'Cabal.flagName' has a prefix matching any valid @USE_EXPAND@,+-- then return 'Nothing'. Otherwise return 'Just' 'Cabal.PackageFlag'.+dropIfUseExpand :: [String] -> Cabal.PackageFlag -> Maybe Cabal.PackageFlag+dropIfUseExpand use_expands flag =+ if True `elem` (L.isPrefixOf <$> use_expands <*> [Cabal.unFlagName . Cabal.flagName $ flag])+ then Nothing else Just flag++-- | Strip @USE_EXPAND@s from a ['Cabal.PackageFlag'].+dropIfUseExpands :: [Cabal.PackageFlag] -> IO [Cabal.PackageFlag]+dropIfUseExpands flags = do+ use_expands <- getUseExpands+ return $ catMaybes (dropIfUseExpand use_expands <$> flags)
Portage/Cabal.hs view
@@ -39,17 +39,17 @@ convertLicense l = case Cabal.licenseFromSPDX l of -- good ones- Cabal.AGPL mv -> Right $ "AGPL-" ++ case (Cabal.prettyShow <$> mv) of+ Cabal.AGPL mv -> Right $ "AGPL-" ++ case Cabal.prettyShow <$> mv of Just "3" -> "3" Just "3.0" -> "3+" _ -> "3" -- almost certainly version 3- Cabal.GPL mv -> Right $ "GPL-" ++ case (Cabal.prettyShow <$> mv) of+ Cabal.GPL mv -> Right $ "GPL-" ++ case Cabal.prettyShow <$> mv of Just "2" -> "2" Just "2.0" -> "2+" Just "3" -> "3" Just "3.0" -> "3+" _ -> "2" -- possibly version 2- Cabal.LGPL mv -> Right $ "LGPL-" ++ case (Cabal.prettyShow <$> mv) of+ Cabal.LGPL mv -> Right $ "LGPL-" ++ case Cabal.prettyShow <$> mv of Just "2" -> "2" -- Cabal can't handle 2.0+ properly Just "2.0" -> "2"@@ -61,7 +61,8 @@ Cabal.BSD4 -> Right "BSD-4" Cabal.PublicDomain -> Right "public-domain" Cabal.MIT -> Right "MIT"- Cabal.Apache mv -> Right $ "Apache-" ++ (maybe "1.1" Cabal.prettyShow mv) -- probably version 1.1+ Cabal.Apache mv -> Right $ "Apache-" +++ maybe "1.1" Cabal.prettyShow mv -- probably version 1.1 Cabal.ISC -> Right "ISC" Cabal.MPL v -> Right $ "MPL-" ++ Cabal.prettyShow v -- probably version 1.0 -- bad ones
Portage/Dependency/Builder.hs view
@@ -23,9 +23,7 @@ mkUseDependency :: (Bool, Use) -> Dependency -> Dependency mkUseDependency (b, u) d =- case b of- True -> DependIfUse u d empty_dependency- False -> DependIfUse u empty_dependency d+ if b then DependIfUse u d empty_dependency else DependIfUse u empty_dependency d overAtom :: (Atom -> Atom) -> Dependency -> Dependency overAtom f (DependAllOf d) = DependAllOf $ map (overAtom f) d
Portage/Dependency/Types.hs view
@@ -20,21 +20,33 @@ , range_is_case_of ) where -import Portage.PackageId-import Portage.Use+import Portage.PackageId+import Portage.Use +import Control.DeepSeq (NFData(..))+ -- | Type of SLOT dependency of a dependency. data SlotDepend = AnySlot -- ^ nothing special | AnyBuildTimeSlot -- ^ ':=' | GivenSlot String -- ^ ':slotno' deriving (Eq, Show, Ord) +instance NFData SlotDepend where+ rnf AnySlot = ()+ rnf AnyBuildTimeSlot = ()+ rnf (GivenSlot s) = rnf s+ -- | Type of lower bound of a dependency. data LBound = StrictLB Version -- ^ greater than (>) | NonstrictLB Version -- ^ greater than or equal to (>=) | ZeroB -- ^ no lower bound deriving (Eq, Show) +instance NFData LBound where+ rnf (StrictLB v) = rnf v+ rnf (NonstrictLB v) = rnf v+ rnf ZeroB = ()+ instance Ord LBound where compare ZeroB ZeroB = EQ compare ZeroB _ = LT@@ -53,6 +65,11 @@ | InfinityB -- ^ no upper bound deriving (Eq, Show) +instance NFData UBound where+ rnf (StrictUB v) = rnf v+ rnf (NonstrictUB v) = rnf v+ rnf InfinityB = ()+ instance Ord UBound where compare InfinityB InfinityB = EQ compare InfinityB _ = GT@@ -74,6 +91,10 @@ | DExact Version deriving (Eq, Show, Ord) +instance NFData DRange where+ rnf (DRange l u) = rnf l `seq` rnf u+ rnf (DExact v) = rnf v+ range_is_case_of :: DRange -> DRange -> Bool range_is_case_of (DRange llow lup) (DRange rlow rup) | llow >= rlow && lup <= rup = True@@ -88,13 +109,25 @@ data DAttr = DAttr SlotDepend [UseFlag] deriving (Eq, Show, Ord) +instance NFData DAttr where+ rnf (DAttr sd uf) = rnf sd `seq` rnf uf+ data Dependency = DependAtom Atom | DependAnyOf [Dependency] | DependAllOf [Dependency] | DependIfUse Use Dependency Dependency -- u? ( td ) !u? ( fd ) deriving (Eq, Show, Ord) +instance NFData Dependency where+ rnf (DependAtom a) = rnf a+ rnf (DependAnyOf ds) = rnf ds+ rnf (DependAllOf ds) = rnf ds+ rnf (DependIfUse u d d') = rnf u `seq` rnf d `seq` rnf d'+ data Atom = Atom PackageName DRange DAttr deriving (Eq, Show, Ord)++instance NFData Atom where+ rnf (Atom pn dr da) = rnf pn `seq` rnf dr `seq` rnf da -- | True if left 'Dependency' constraint is the same as (or looser than) right -- 'Dependency' constraint.
Portage/EBuild.hs view
@@ -18,9 +18,9 @@ , quote ) where -import Portage.Dependency-import Portage.EBuild.CabalFeature-import Portage.EBuild.Render+import Portage.Dependency+import Portage.EBuild.CabalFeature+import Portage.EBuild.Render import qualified Portage.Dependency.Normalize as PN import qualified Data.Time.Clock as TC@@ -28,7 +28,9 @@ import qualified Data.Function as F import qualified Data.List as L import qualified Data.List.Split as LS-import Data.Version(Version(..))+import Data.Version(Version(..))++import Network.URI import qualified Paths_hackport(version) #if ! MIN_VERSION_time(1,5,0)@@ -75,7 +77,7 @@ hackportVersion = getHackportVersion Paths_hackport.version, description = "", long_desc = "",- homepage = "http://hackage.haskell.org/package/${HACKAGE_N}",+ homepage = "https://hackage.haskell.org/package/${HACKAGE_N}", license = Left "unassigned license?", slot = "0", keywords = ["~amd64","~x86"],@@ -154,11 +156,31 @@ expandVars = replaceMultiVars [ ( name ebuild, "${PN}") , (hackage_name ebuild, "${HACKAGE_N}") ]- -- TODO: this needs to be more generic- toHttps = replace "http://github.com/" "https://github.com/"++ replace old new = L.intercalate new . LS.splitOn old+ -- add to this list with any https-aware websites+ -- TODO: perhaps convert this to a list of http-only webpages,+ -- given the prominence of https these days (year 2020).+ httpsHomepages = Just <$> [ "github.com"+ , "hackage.haskell.org"+ , "www.haskell.org"+ , "hledger.org"+ , "jaspervdj.be"+ , "www.yesodweb.com"+ ]+ toHttps :: String -> String+ toHttps x =+ case parseURI x of+ Just uri -> if uriScheme uri == "http:" &&+ (uriRegName <$> uriAuthority uri)+ `elem`+ httpsHomepages+ then replace "http" "https" x+ else x+ Nothing -> x+ this_year :: String this_year = TC.formatTime TC.defaultTimeLocale "%Y" now- replace old new = L.intercalate new . LS.splitOn old -- | Sort IUSE alphabetically --
Portage/Host.hs view
@@ -5,8 +5,7 @@ import Util (run_cmd) import qualified Data.List.Split as DLS-import Data.Maybe (fromJust, isJust, catMaybes)-import Control.Applicative ( (<$>) )+import Data.Maybe (fromJust, isJust, mapMaybe) import qualified System.Directory as D import System.FilePath ((</>))@@ -61,9 +60,7 @@ do home_dir <- D.getHomeDirectory let config_path = home_dir </> hackport_config exists <- D.doesFileExist config_path- case exists of- True -> read <$> readFile config_path- False -> return Nothing+ if exists then read <$> readFile config_path else return Nothing ---------- -- Paludis@@ -75,7 +72,7 @@ parsePaludisInfo :: String -> LocalInfo parsePaludisInfo text = let chunks = DLS.splitOn [""] . lines $ text- repositories = catMaybes (map parseRepository chunks)+ repositories = mapMaybe parseRepository chunks in fromJust (mkLocalInfo repositories) where parseRepository :: [String] -> Maybe (String, (String, String))@@ -110,7 +107,7 @@ hsRepo <- run_cmd "portageq get_repo_path / haskell" --There really ought to be both distdir and portdir, --but maybe no hsRepo defined yet.- let info = if any (==Nothing) [distdir,portdir]+ let info = if Nothing `elem` [distdir,portdir] then Nothing else Just LocalInfo { distfiles_dir = grab distdir
Portage/Metadata.hs view
@@ -17,9 +17,10 @@ import qualified AnsiColor as A -import qualified Data.Text as T-import qualified Data.Text.IO as T+import qualified Data.List as L import qualified Data.Map.Strict as Map+import qualified Data.Text as T+import qualified Data.Text.IO as T import Text.XML.Light @@ -76,14 +77,16 @@ -- | Pretty print as valid XML a list of flags and their descriptions -- from a given 'Map.Map'. prettyPrintFlags :: Map.Map String String -> [String]-prettyPrintFlags m = (\(name,description) -> "\t\t<flag name=\"" ++ name ++- "\">" ++ description ++ "</flag>")+prettyPrintFlags m = (\(name,description) ->+ "\t\t<flag name=\"" ++ name ++ "\">" +++ (L.intercalate " " . lines $ description) ++ "</flag>") <$> Map.toAscList m -- | Pretty print a human-readable list of flags and their descriptions -- from a given 'Map.Map'. prettyPrintFlagsHuman :: Map.Map String String -> [String]-prettyPrintFlagsHuman m = (\(name,description) -> A.bold (name ++ ": ") ++ description)+prettyPrintFlagsHuman m = (\(name,description) -> A.bold (name ++ ": ") +++ (L.intercalate " " . lines $ description)) <$> Map.toAscList m -- | A minimal metadata for use as a fallback value.@@ -94,27 +97,43 @@ -- don't use Text.XML.Light as we like our own pretty printer -- | Pretty print the @metadata.xml@ string.+--+-- This function will additionally print the @<use>@ and @<longdescription>@+-- xml elements if:+--+-- 1. There are USE flags to fill the @<use>@ element, which cannot be empty;+-- and+-- 2. The long description is greater than 150 characters long.+--+-- The long description also cannot be identical to the @DESCRIPTION@ field+-- in an ebuild in order to pass Gentoo QA, but this is checked for outside+-- of this function. See "Merge" for an example usage. makeDefaultMetadata :: String -> Map.Map String String -> T.Text-makeDefaultMetadata long_description flags =- T.pack $ unlines [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"- , "<!DOCTYPE pkgmetadata SYSTEM \"http://www.gentoo.org/dtd/metadata.dtd\">"- , "<pkgmetadata>"- , "\t<maintainer type=\"project\">"- , "\t\t<email>haskell@gentoo.org</email>"- , "\t\t<name>Gentoo Haskell</name>"- , "\t</maintainer>"- , "\t<use>\n" ++ (unlines $ prettyPrintFlags flags) ++ "\t</use>"- , (init {- strip trailing newline-}- . unlines- . map (\l -> if l `elem` ["<longdescription>", "</longdescription>"]- then "\t" ++ l -- leading/trailing lines- else "\t\t" ++ l -- description itself- )- . lines- . showElement- . unode "longdescription"- . ("\n" ++) -- prepend newline to separate form <longdescription>- . (++ "\n") -- append newline- ) long_description- , "</pkgmetadata>"- ]+makeDefaultMetadata long_description flags = T.pack $+ unlines [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"+ , "<!DOCTYPE pkgmetadata SYSTEM \"http://www.gentoo.org/dtd/metadata.dtd\">"+ , "<pkgmetadata>"+ , "\t<maintainer type=\"project\">"+ , "\t\t<email>haskell@gentoo.org</email>"+ , "\t\t<name>Gentoo Haskell</name>"+ , "\t</maintainer>"+ ++ if flags == Map.empty+ then []+ else "\n\t<use>\n" ++ (unlines $ prettyPrintFlags flags) ++ "\t</use>"+ ++ if long_description == "" || length long_description <= 150+ then []+ else "\n" +++ (init {- strip trailing newline-}+ . unlines+ . map (\l -> if l `elem` ["<longdescription>", "</longdescription>"]+ then "\t" ++ l -- leading/trailing lines+ else "\t\t" ++ l -- description itself+ )+ . lines+ . showElement+ . unode "longdescription"+ . ("\n" ++) -- prepend newline to separate from <longdescription>+ . (++ "\n") -- append newline+ ) long_description+ , "</pkgmetadata>"+ ]
Portage/Overlay.hs view
@@ -26,8 +26,6 @@ import System.IO.Unsafe (unsafeInterleaveIO) import System.FilePath ((</>), splitExtension) -import Data.Traversable ( traverse )- data ExistingEbuild = ExistingEbuild { ebuildId :: Portage.PackageId, ebuildCabalId :: Cabal.PackageIdentifier,
Portage/PackageId.hs view
@@ -29,6 +29,7 @@ import qualified Portage.Version as Portage +import Control.DeepSeq (NFData(..)) import qualified Data.Char as Char import qualified Text.PrettyPrint as Disp import Text.PrettyPrint ((<>))@@ -49,6 +50,9 @@ data PackageId = PackageId { packageId :: PackageName, pkgVersion :: Portage.Version } deriving (Eq, Ord, Show, Read) +instance NFData Category where+ rnf (Category c) = rnf c+ instance Pretty Category where pretty (Category c) = Disp.text c @@ -57,6 +61,9 @@ where categoryChar c = Char.isAlphaNum c || c == '-' +instance NFData PackageName where+ rnf (PackageName c pn) = rnf c `seq` rnf pn+ instance Pretty PackageName where pretty (PackageName cat name) = pretty cat <> Disp.char '/' <> pretty name@@ -67,6 +74,9 @@ _ <- P.char '/' name <- parseCabalPackageName return $ PackageName cat name++instance NFData PackageId where+ rnf (PackageId pId pv) = rnf pId `seq` rnf pv instance Pretty PackageId where pretty (PackageId name version) =
Portage/Use.hs view
@@ -15,6 +15,8 @@ import Text.PrettyPrint ((<>)) import Distribution.Pretty (Pretty(..)) +import Control.DeepSeq (NFData(..))+ #if MIN_VERSION_base(4,11,0) import Prelude hiding ((<>)) #endif@@ -27,6 +29,13 @@ | N UseFlag -- ^ - modificator deriving (Eq,Show,Ord,Read) +instance NFData UseFlag where+ rnf (UseFlag u) = rnf u+ rnf (E f) = rnf f+ rnf (Q f) = rnf f+ rnf (X f) = rnf f+ rnf (N f) = rnf f+ instance Pretty UseFlag where pretty = showModificator @@ -52,6 +61,9 @@ newtype Use = Use String deriving (Eq, Read, Show)++instance NFData Use where+ rnf (Use s) = rnf s instance Pretty Use where pretty (Use u) = Disp.text u
Portage/Version.hs view
@@ -27,6 +27,8 @@ import Text.PrettyPrint ((<>)) import qualified Data.List.NonEmpty as NE +import Control.DeepSeq (NFData(..))+ #if MIN_VERSION_base(4,11,0) import Prelude hiding ((<>)) #endif@@ -39,6 +41,9 @@ } deriving (Eq, Ord, Show, Read) +instance NFData Version where+ rnf (Version n c s r) = rnf n `seq` rnf c `seq` rnf s `seq` rnf r+ -- | Prints a valid Portage 'Version' string. instance Pretty Version where pretty (Version ver c suf rev) =@@ -90,6 +95,13 @@ -- | Various allowed suffixes in Portage versions. data Suffix = Alpha Int | Beta Int | Pre Int | RC Int | P Int deriving (Eq, Ord, Show, Read)++instance NFData Suffix where+ rnf (Alpha n) = rnf n+ rnf (Beta n) = rnf n+ rnf (Pre n) = rnf n+ rnf (RC n) = rnf n+ rnf (P n) = rnf n instance Pretty Suffix where pretty suf = case suf of
Status.hs view
@@ -246,6 +246,13 @@ equal' :: BS.ByteString -> BS.ByteString -> Bool equal' = Cabal.equating essence where- essence = filter (not . isEmpty) . filter (not . isComment) . BS.lines+ essence = filter (not . isEmpty)+ . filter (not . isComment)+ . filter (not . isHOMEPAGE)+ . BS.lines isComment = BS.isPrefixOf (BS.pack "#") . BS.dropWhile isSpace+ -- HOMEPAGE= frequently gets updated for http:// / https://.+ -- It's to much noise usually and should really be fixed+ -- in upstream Cabal definition.+ isHOMEPAGE = BS.isPrefixOf (BS.pack "HOMEPAGE=") . BS.dropWhile isSpace isEmpty = BS.null . BS.dropWhile isSpace
hackport.cabal view
@@ -1,6 +1,6 @@ Name: hackport-Version: 0.6.6-License: GPL-3+Version: 0.6.7+License: GPL License-file: LICENSE Author: Henning Günther, Duncan Coutts, Lennart Kolmodin Maintainer: Gentoo Haskell team <haskell@gentoo.org>@@ -16,10 +16,10 @@ location: git://github.com/gentoo-haskell/hackport.git Executable hackport- ghc-options: -Wall+ ghc-options: -Wall -threaded +RTS -N -RTS ghc-prof-options: -caf-all -auto-all -rtsopts Main-Is: Main.hs- Default-Language: Haskell98+ Default-Language: Haskell2010 Hs-Source-Dirs: ., cabal,@@ -37,6 +37,7 @@ filepath >= 1.3.0.1, HTTP >= 4000.1.5, network >= 2.6, network-uri >= 2.6,+ parallel >= 3.2.1.0, parsec >= 3.1.13, pretty >= 1.1.1, process >= 1.1.0.2,@@ -57,7 +58,7 @@ random >= 1.0, stm >= 2.0, -- hackage-security depends- base16-bytestring >= 0.1.1,+ base16-bytestring >= 0.1.1 && < 1, base64-bytestring >= 1.0, cryptohash-sha256 >= 0.11, ed25519,@@ -758,6 +759,7 @@ filepath, hspec >= 2.0, mtl,+ network-uri, parsec, pretty, process,
tests/Merge/UtilsSpec.hs view
@@ -7,6 +7,7 @@ import Control.Applicative (liftA2) import qualified Data.Map.Strict as Map+import Data.Maybe (catMaybes) import qualified Data.List as L import Error@@ -118,3 +119,16 @@ \name desc -> metaFlags [(Cabal.emptyFlag (Cabal.mkFlagName name)) { Cabal.flagDescription = desc }] == Map.fromList [(mangle_iuse name,desc)]++ describe "dropIfUseExpand" $ do+ it "drops a USE flag if it is a USE_EXPAND, otherwise preserves it" $ do+ let use_expands = ["cpu_flags_x86","cpu_flags_arm"]+ flags = Cabal.emptyFlag . Cabal.mkFlagName <$>+ [ "cpu_flags_x86_sse4_2"+ , "foo"+ , "bar"+ , "baz"+ , "cpu_flags_arm_v8"+ ]+ Cabal.unFlagName . Cabal.flagName <$> catMaybes (dropIfUseExpand use_expands <$> flags)+ `shouldBe` ["foo","bar","baz"]
− tests/Merge/UtilsSpec.hs~
@@ -1,53 +0,0 @@-module Merge.UtilsSpec (spec) where--import Test.Hspec--import Error-import Merge.Utils-import Portage.PackageId--import qualified Distribution.Package as Cabal--spec :: Spec-spec = do- describe "(<.>)" $ do- it "adds a dot (.) between two strings" $ do- "foo" <.> "bar" `shouldBe` "foo.bar"-- describe "readPackageString" $ do- context "when the package string is valid" $ do- it "returns a Right tuple containing the parsed information" $ do- readPackageString ["dev-haskell/packagename1-1.0.0"]- `shouldBe` Right ( Just (Category "dev-haskell")- , Cabal.mkPackageName "packagename1"- , Just (Version [1,0,0] Nothing [] 0)- )- context "when the package string is empty" $ do- it "returns a Left HackPortError" $ do- readPackageString []- `shouldBe`- Left (ArgumentError "Need an argument, [category/]package[-version]")- context "when the package string contains too many arguments" $ do- it "returns a Left HackPortError" $ do- let args = ["dev-haskell/packagename1-1.0.0", "dev-haskell/packagename2-1.0.0"]- readPackageString args- `shouldBe`- Left (ArgumentError ("Too many arguments: " ++ unwords args))-- - - - -- describe "getPreviousPackageId" $ do- -- it "returns the PackageId of the previous version" $ do- -- let ebuildDir = [ "foo-bar2-3.0.0b_rc2-r1.ebuild"- -- , "foo-bar2-3.0.0b_rc2-r2.ebuild"- -- , "foo-bar2-3.0.1.ebuild"- -- , "metadata.xml"- -- , "Manifest"- -- , "files"- -- ]- -- newPkgId = PackageId (PackageName (Category "dev-haskell")- -- (Cabal.mkPackageName "foo-bar2"))- -- Version - -
tests/Portage/EBuildSpec.hs view
@@ -26,4 +26,7 @@ quote "Reading, writing and manipulating '.tar' archives." "" `shouldBe` "\"Reading, writing and manipulating \'.tar\' archives.\""- + quote "Extras for the \"contravariant\" package" ""+ `shouldBe`+ "\"Extras for the \\\"contravariant\\\" package\""+
tests/Portage/MetadataSpec.hs view
@@ -3,6 +3,7 @@ import Test.Hspec import Test.Hspec.QuickCheck +import qualified Data.List as L import qualified Data.Text as T import qualified Data.Map.Strict as Map @@ -25,16 +26,17 @@ prop "should correctly format a single USE flag name with its description" $ do \name description -> prettyPrintFlags (Map.singleton name description) == ["\t\t<flag name=\"" ++ name ++- "\">" ++ description ++ "</flag>"]+ "\">" ++ (L.intercalate " " . lines $ description)+ ++ "</flag>"] prop "should have a length equal to the number of USE flags" $ do \flags -> length (prettyPrintFlags flags) == Map.size flags describe "makeDefaultMetadata" $ do- context "when writing a minimal metadata.xml" $ do+ context "when writing a minimal metadata.xml with no USE flags" $ do it "should have a certain number of lines" $ do -- This is the number of lines in a skeleton metadata.xml. -- If it does not equal this number, the formatting may be wrong.- length (T.lines (makeDefaultMetadata "" Map.empty)) `shouldBe` 13+ length (T.lines (makeDefaultMetadata "" Map.empty)) `shouldBe` 8 it "should have a certain format" $ do let desc = "foo" correctMetadata = T.pack $ unlines@@ -45,21 +47,39 @@ , "\t\t<email>haskell@gentoo.org</email>" , "\t\t<name>Gentoo Haskell</name>" , "\t</maintainer>"- , "\t<use>"- , "\t</use>"- , "\t<longdescription>"- , "\t\t" ++ desc- , "\t</longdescription>" , "</pkgmetadata>" ] in makeDefaultMetadata desc Map.empty `shouldBe` correctMetadata context "when writing a metadata.xml with USE flags" $ do- it "should have a certain number of lines relative to the number of USE flags" $ do+ it "should have a certain number of lines" $ do let flags = Map.singleton "name" "description" in length (T.lines (makeDefaultMetadata "" flags))- `shouldBe` 13 + (Map.size flags)- it "should have a certain format" $ do+ `shouldBe` 10 + (Map.size flags)+ it "should have a certain format, including the <use> element" $ do let desc = "foo"+ flags = Map.singleton "name" "description"+ correctMetadata = T.pack $ unlines+ [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"+ , "<!DOCTYPE pkgmetadata SYSTEM \"http://www.gentoo.org/dtd/metadata.dtd\">"+ , "<pkgmetadata>"+ , "\t<maintainer type=\"project\">"+ , "\t\t<email>haskell@gentoo.org</email>"+ , "\t\t<name>Gentoo Haskell</name>"+ , "\t</maintainer>"+ , "\t<use>"+ , "\t\t<flag name=\"name\">description</flag>"+ , "\t</use>"+ , "</pkgmetadata>"+ ]+ in makeDefaultMetadata desc flags `shouldBe` correctMetadata+ context "when writing a metadata.xml with a valid long description and USE flags" $ do+ it "has a certain number of lines" $ do+ let desc = replicate 151 'a'+ flags = Map.singleton "name" "description"+ in length (T.lines (makeDefaultMetadata desc flags))+ `shouldBe` 13 + (Map.size flags)+ it "writes the <longdescription> and <use> elements into the metadata.xml" $ do+ let desc = replicate 151 'a' flags = Map.singleton "name" "description" correctMetadata = T.pack $ unlines [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
tests/Portage/VersionSpec.hs view
@@ -2,8 +2,8 @@ import Test.Hspec import Test.Hspec.QuickCheck- import QuickCheck.Instances+ import qualified Distribution.Version as Cabal import Portage.Version@@ -12,8 +12,8 @@ spec = do describe "is_live" $ do prop "determines if a Portage version is live" $ do- \(ComplexVersion v) -> is_live v ==- if length (versionNumber v) >= 1 && last (versionNumber v) >= 9999+ \(ComplexVersion v) -> is_live v `shouldBe`+ if last (versionNumber v) >= 9999 then True else False describe "fromCabalVersion" $ do
tests/QuickCheck/Instances.hs view
@@ -38,7 +38,7 @@ instance Arbitrary ComplexVersion where arbitrary = do v <- listOf1 $ getNonNegative <$> arbitrary- c <- Just <$> choose ('a','z')+ c <- oneof $ [Just <$> choose ('a','z'), elements [Nothing]] s <- listOf $ getSuffix <$> arbitrary (NonNegative r) <- arbitrary return $ ComplexVersion $ Version v (if length v == 1 then Nothing else c) s r