e9bf1db · typeable/cabal2nix

git.iko.soy/typeable/cabal2nix

hackage2nix: re-write Hackage interface for reduced memory consumption

@bennofs argued in https://github.com/NixOS/cabal2nix/pull/191 that building a lazily evaluated map of all GenericPackageDescription files found in Hackage is a bad idea. Following his advice, this patch changes the Hackage type from Map String (Map Version GenericPackageDescription) to Map PackageName (Set Version). Instead of reading all files from the outset, we just build a dictionary of available versions plus functions that conveniently read a file once we know it's actually required.

commite9bf1db45511bcdb9ecebffe04b6a21cfd2ecf53 authorPeter Simons <simons@cryp.to> dateFri 18 Sep 2015, 12:27 (11 years ago) parent2d6e3ac

2 files changed+98−101

compare with master

unifiedsplit

hackage2nix/src/HackageGit.hs+48−48 hackage2nix/src/Main.hs+50−53

hackage2nix/src/HackageGit.hs+48−48

@@ -1,79 +1,79 @@

11{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE TemplateHaskell #-}

34module HackageGit where

56import Control.Monad

7+import Control.Lens hiding ( (<.>) )

68import Data.Aeson

79import Data.ByteString.Char8 ( ByteString )

810import qualified Data.ByteString.Char8 as BS

911import Data.ByteString.Lazy.Char8 ( fromStrict )

1012import Data.Digest.Pure.SHA ( sha256, showDigest )

11−import Data.List ( foldl' )

12−import Data.Map

13−import Data.Maybe ( fromMaybe )

13+import Data.Map as Map

14+import Data.Set as Set

15+import Data.String

1416import Data.String.UTF8 ( toString, fromRep )

17+import Distribution.Nixpkgs.Haskell.OrphanInstances ( )

18+import Distribution.Package

1519import Distribution.PackageDescription

1620import Distribution.PackageDescription.Parse ( parsePackageDescription, ParseResult(..) )

17−import Distribution.Text ( simpleParse )

18−import Distribution.Version ( Version )

21+import Distribution.Text

22+import Distribution.Version

1923import System.Directory

2024import System.FilePath

21−import System.IO.Unsafe

2225

23−type Hackage = Map String (Map Version GenericPackageDescription)

26+type Hackage = Map PackageName (Set Version)

2427

2528readHackage :: FilePath -> IO Hackage

26−readHackage path = do db <- getSubDirs path >>= foldM discoverPackageVersions empty

27− return $ mapWithKey (\pkg -> Data.List.foldl' (makeVersionMap pkg) empty) db

29+readHackage path = getSubDirs path >>= foldM discoverPackageVersions mempty

2830 where

29− discoverPackageVersions :: Map String [String] -> String -> IO (Map String [String])

30− discoverPackageVersions db pkg = getSubDirs (path </> pkg) >>= \vs -> return (insert pkg vs db)

31−

32− makeVersionMap :: String -> Map Version GenericPackageDescription -> String -> Map Version GenericPackageDescription

33− makeVersionMap pkg db v = insert (parseVersion v) (unsafePerformIO (readHackagePackage path pkg v)) db

34−

35−readHackagePackage :: FilePath -> String -> String -> IO GenericPackageDescription

36−readHackagePackage path pkg version = do

37− let cabalFile = path </> pkg </> version </> pkg <.> "cabal"

38− metaFile = path </> pkg </> version </> pkg <.> "json"

39− buf <- BS.readFile cabalFile

40− meta <- parseMeta path version <$> BS.readFile metaFile

41− cabal <- case parsePackageDescription (decodeUTF8 buf) of

42− ParseOk _ a -> return a

43− ParseFailed err -> fail $ cabalFile ++ ": " ++ show err

44− let cabal' = cabal { packageDescription = pd { customFieldsPD = cf } }

45− pd = packageDescription cabal

46− cf = customFieldsPD pd ++ ("X-Cabal-File-Hash", mkSHA256 buf)

47− : [ ("X-Package-" ++ k, v') | (k,v') <- toList (hashes meta) ]

48− return cabal'

49−

50−parseVersion :: String -> Version

51−parseVersion str = fromMaybe (error $ "hackage-db: cannot parse version " ++ show str) (simpleParse str)

52−

53−decodeUTF8 :: ByteString -> String

54−decodeUTF8 = toString . fromRep

31+ discoverPackageVersions :: Hackage -> String -> IO Hackage

32+ discoverPackageVersions db pkg = do

33+ vs <- getSubDirs (path </> pkg)

34+ return (Map.insert (PackageName pkg) (Set.fromList (Prelude.map fromString vs)) db)

5535

5636getSubDirs :: FilePath -> IO [FilePath]

5737getSubDirs path = do

5838 let isDirectory p = doesDirectoryExist (path </> p)

5939 getDirectoryContents path >>= filterM isDirectory . Prelude.filter (\x -> head x /= '.')

6040

61−mkSHA256 :: ByteString -> String

41+decodeUTF8 :: ByteString -> String

42+decodeUTF8 = toString . fromRep

43+

44+type SHA256Hash = String

45+

46+readPackage :: FilePath -> PackageIdentifier -> IO (GenericPackageDescription, SHA256Hash)

47+readPackage dirPrefix (PackageIdentifier name version) = do

48+ let cabalFile = dirPrefix </> unPackageName name </> display version </> unPackageName name <.> "cabal"

49+ buf <- BS.readFile cabalFile

50+ cabal <- case parsePackageDescription (decodeUTF8 buf) of

51+ ParseOk _ a -> return a

52+ ParseFailed err -> fail (cabalFile ++ ": " ++ show err)

53+ return (cabal, mkSHA256 buf)

54+

55+mkSHA256 :: ByteString -> SHA256Hash

6256mkSHA256 = showDigest . sha256 . fromStrict

6357

64−data Meta = Meta { hashes :: Map String String {-, locations :: [String], pkgsize :: Int-} }

65− deriving (Show)

58+declareLenses [d|

59+ data Meta = Meta { hashes :: Map String String

60+ , locations :: [String]

61+ , pkgsize :: Int

62+ }

63+ deriving (Show)

64+ |]

6665

6766instance FromJSON Meta where

68− parseJSON (Object v) = Meta <$>

69− v .: "package-hashes" {- <*>

70− v .: "package-locations" <*>

71− v .: "package-size" -}

72− -- A non-Object value is of the wrong type, so fail.

73− parseJSON _ = mzero

67+ parseJSON (Object v) = Meta

68+ <$> v .: "package-hashes"

69+ <*> v .: "package-locations"

70+ <*> v .: "package-size"

71+ parseJSON o = fail ("invalid Cabal metadata: " ++ show o)

7472

75−parseMeta :: String -> String -> ByteString -> Meta

76−parseMeta pkg version buf =

73+readPackageMeta :: FilePath -> PackageIdentifier -> IO Meta

74+readPackageMeta dirPrefix (PackageIdentifier name version) = do

75+ let metaFile = dirPrefix </> unPackageName name </> display version </> unPackageName name <.> "json"

76+ buf <- BS.readFile metaFile

7777 case eitherDecodeStrict buf of

78− Left msg -> error $ "hackage-db: cannot decode JSON meta data for " ++ pkg ++ "-" ++ version ++ ":" ++ msg

79− Right x -> x

78+ Left msg -> fail (metaFile ++ ": " ++ msg)

79+ Right x -> return x

hackage2nix/src/Main.hs+50−53

@@ -29,7 +29,7 @@ import Distribution.PackageDescription hiding ( options, buildDepends, extraLibs

2929import Distribution.System

3030import Distribution.Text

3131import Distribution.Version

32−import HackageGit ( readHackage, Hackage )

32+import HackageGit

3333import Language.Nix

3434import Options.Applicative

3535import qualified Paths_hackage2nix as Main

@@ -38,9 +38,8 @@ import System.FilePath

3838import System.IO

3939import Text.PrettyPrint.HughesPJClass hiding ( (<>) )

4040

41−-- type Nixpkgs = PackageMap -- Map String (Set [String])

42−type PackageSet = Map String Version

43−type PackageMultiSet = Map String (Set Version)

41+type PackageSet = Map PackageName Version

42+type PackageMultiSet = Map PackageName (Set Version)

4443

4544data CLI = CLI

4645 { hackageRepository :: FilePath

@@ -94,13 +93,13 @@ main = do

9493 hackagePackagesFile = nixpkgsRepository </> "pkgs/development/haskell-modules/hackage-packages.nix"

9594

9695 corePackageSet :: PackageSet

97− corePackageSet = Map.fromList [ (name, v) | PackageIdentifier (PackageName name) v <- Set.toList (Config.corePackages config) ]

96+ corePackageSet = Map.fromList [ (name, v) | PackageIdentifier name v <- Set.toList (Config.corePackages config) ]

9897

9998 latestVersionSet :: PackageSet

100− latestVersionSet = Map.map (Set.findMax . Map.keysSet) (Map.filter (/= Map.empty) (Map.mapWithKey (enforcePreferredVersions preferredVersions) hackage))

99+ latestVersionSet = Map.map Set.findMax (Map.filter (not . Set.null) (Map.mapWithKey (enforcePreferredVersions preferredVersions) hackage))

101100

102101 defaultPackageOverridesSet :: PackageSet

103− defaultPackageOverridesSet = Map.fromList [ (name, resolveConstraint c hackage) | c@(Dependency (PackageName name) _) <- defaultPackageOverrides config ]

102+ defaultPackageOverridesSet = Map.fromList [ (name, resolveConstraint c hackage) | c@(Dependency name _) <- defaultPackageOverrides config ]

104103

105104 generatedDefaultPackageSet :: PackageSet

106105 generatedDefaultPackageSet = (defaultPackageOverridesSet `Map.union` latestVersionSet) `Map.difference` corePackageSet

@@ -113,10 +112,10 @@ main = do

113112

114113 extraPackageSet :: PackageMultiSet

115114 extraPackageSet = Map.unionsWith Set.union

116− [ Map.singleton name (Set.singleton (resolveConstraint c hackage)) | c@(Dependency (PackageName name) _) <- extraPackages config ]

115+ [ Map.singleton name (Set.singleton (resolveConstraint c hackage)) | c@(Dependency name _) <- extraPackages config ]

117116

118− stackagePackageSet :: Map String (Map Version Spec)

119− stackagePackageSet = Map.fromListWith Map.union [ (unPackageName n, Map.singleton (Stackage.version spec) spec) | snapshot <- nightly:snapshots, (n, spec) <- Map.toList (packages snapshot) ]

117+ stackagePackageSet :: Map PackageName (Map Version Spec)

118+ stackagePackageSet = Map.fromListWith Map.union [ (n, Map.singleton (Stackage.version spec) spec) | snapshot <- nightly:snapshots, (n, spec) <- Map.toList (packages snapshot) ]

120119

121120 db :: PackageMultiSet

122121 db = Map.unionsWith Set.union [ Map.map Set.singleton generatedDefaultPackageSet

@@ -127,7 +126,7 @@ main = do

127126 ]

128127

129128 haskellResolver :: Dependency -> Bool

130− haskellResolver (Dependency (PackageName name) vrange)

129+ haskellResolver (Dependency name vrange)

131130 | Just v <- Map.lookup name corePackageSet = v `withinRange` vrange

132131 | Just v <- Map.lookup name generatedDefaultPackageSet = v `withinRange` vrange

133132 | otherwise = False

@@ -139,45 +138,44 @@ main = do

139138 globalPackageMaintainers = Map.unionsWith Set.union [ Map.singleton p (Set.singleton m) | (m,ps) <- Map.toList (packageMaintainers config), p <- Set.toList ps ]

140139

141140 pkgs <- runParIO $ flip parMapM (Map.toAscList db) $ \(name, vs) -> do

142− let defs = flip map (Set.toAscList vs) $ \v ->

143− let

144− pkgId :: PackageIdentifier

145− pkgId = PackageIdentifier (PackageName name) v

141+ defs <- flip mapM (Set.toAscList vs) $ \v -> liftIO $ do

142+ let pkgId :: PackageIdentifier

143+ pkgId = PackageIdentifier name v

146144

147− isInDefaultPackageSet :: Bool

148− isInDefaultPackageSet = maybe False (== v) (Map.lookup name generatedDefaultPackageSet)

145+ (descr, cabalSHA256) <- readPackage hackageRepository pkgId

146+ meta <- readPackageMeta hackageRepository pkgId

149147

150− abort :: String -> a

151− abort msg = error (display pkgId ++ ": " ++ msg)

148+ let isInDefaultPackageSet :: Bool

149+ isInDefaultPackageSet = maybe False (== v) (Map.lookup name generatedDefaultPackageSet)

152150

153− descr :: GenericPackageDescription

154− descr = fromMaybe (abort "not on Hackage") (Map.lookup name hackage >>= Map.lookup v)

151+ tarballSHA256 :: SHA256Hash

152+ tarballSHA256 = fromMaybe (error (display pkgId ++ ": meta data has no hash for the tarball"))

153+ (view (hashes . at "SHA256") meta)

155154

156− sha256 :: String

157− sha256 = fromMaybe (abort "has no hash") (lookup "X-Package-SHA256" (customFieldsPD (packageDescription descr)))

155+ spec :: Spec

156+ spec = Spec v mempty True True True `fromMaybe` (Map.lookup name stackagePackageSet >>= Map.lookup v)

158157

159− spec :: Spec

160− spec = Spec v mempty True True True `fromMaybe` (Map.lookup name stackagePackageSet >>= Map.lookup v)

158+ flagAssignment :: FlagAssignment -- We don't use the flags from Stackage Nightly here, because

159+ flagAssignment = configureCabalFlags pkgId -- they are chosen specifically for GHC 7.10.2.

161160

162− flagAssignment :: FlagAssignment -- We don't use the flags from Stackage Nightly here, because

163− flagAssignment = configureCabalFlags pkgId -- they are chosen specifically for GHC 7.10.2.

161+ attr :: String

162+ attr = if isInDefaultPackageSet then unPackageName name else mangle pkgId

164163

165− attr :: String

166− attr = if isInDefaultPackageSet then name else mangle pkgId

164+ drv :: Derivation

165+ drv = fromGenericPackageDescription haskellResolver nixpkgsResolver targetPlatform (compilerInfo config) flagAssignment [] descr

166+ & src .~ DerivationSource "url" ("mirror://hackage/" ++ display pkgId ++ ".tar.gz") "" tarballSHA256

167+ & editedCabalFile .~ cabalSHA256

168+ & Derivation.runHaddock &&~ Stackage.runHaddock spec

169+ & doCheck &&~ runTests spec

170+ & metaSection.hydraPlatforms %~ (`Set.difference` Map.findWithDefault Set.empty name (dontDistributePackages config))

171+ & metaSection.maintainers .~ Map.findWithDefault Set.empty name globalPackageMaintainers

172+ & metaSection.hydraPlatforms %~ (if isInDefaultPackageSet then id else const Set.empty)

167173

168− drv :: Derivation

169− drv = fromGenericPackageDescription haskellResolver nixpkgsResolver targetPlatform (compilerInfo config) flagAssignment [] descr

170− & src .~ DerivationSource "url" ("mirror://hackage/" ++ display pkgId ++ ".tar.gz") "" sha256

171− & Derivation.runHaddock &&~ Stackage.runHaddock spec

172− & doCheck &&~ runTests spec

173− & metaSection.hydraPlatforms %~ (`Set.difference` Map.findWithDefault Set.empty (PackageName name) (dontDistributePackages config))

174− & metaSection.maintainers .~ Map.findWithDefault Set.empty (PackageName name) globalPackageMaintainers

175− & metaSection.hydraPlatforms %~ (if isInDefaultPackageSet then id else const Set.empty)

174+ overrides :: Doc

175+ overrides = fcat $ punctuate space [ pPrint b | b <- Set.toList (view (dependencies . each) drv), not (isFromHackage b) ]

176+ return $ render $ nest 2 $

177+ hang (doubleQuotes (text attr) <+> equals <+> text "callPackage") 2 (parens (pPrint drv)) <+> (braces overrides <> semi)

176178

177− overrides :: Doc

178− overrides = fcat $ punctuate space [ pPrint b | b <- Set.toList (view (dependencies . each) drv), not (isFromHackage b) ]

179− in

180− render $ nest 2 $ hang (doubleQuotes (text attr) <+> equals <+> text "callPackage") 2 (parens (pPrint drv)) <+> (braces overrides <> semi)

181179 return (intercalate "\n\n" defs)

182180

183181 withFile hackagePackagesFile WriteMode $ \h -> do

@@ -193,14 +191,14 @@ main = do

193191 void $ runParIO $ flip parMapM snapshots $ \Snapshot {..} -> liftIO $ do

194192 let allPackages :: PackageSet

195193 allPackages = Map.difference

196− (Map.fromList [ (name, Stackage.version spec) | (PackageName name, spec) <- Map.toList packages ] `Map.union` generatedDefaultPackageSet)

194+ (Map.fromList [ (name, Stackage.version spec) | (name, spec) <- Map.toList packages ] `Map.union` generatedDefaultPackageSet)

197195 corePackages'

198196

199197 ltsConfigFile :: FilePath

200198 ltsConfigFile = nixpkgsRepository </> "pkgs/development/haskell-modules/configuration-" ++ show (pPrint snapshot) ++ ".nix"

201199

202200 corePackages' :: PackageSet

203− corePackages' = Map.mapKeys unPackageName corePackages `Map.union` Map.fromList [("Cabal", Version [] []), ("rts", Version [] [])]

201+ corePackages' = corePackages `Map.union` Map.fromList [("Cabal", Version [] []), ("rts", Version [] [])]

204202

205203 withFile ltsConfigFile WriteMode $ \h -> do

206204 hPutStrLn h "{ pkgs }:"

@@ -211,21 +209,21 @@ main = do

211209 hPutStrLn h ""

212210 hPutStrLn h " # core libraries provided by the compiler"

213211 forM_ (Map.keys corePackages') $ \n ->

214− unless (n == "ghc") (hPutStrLn h (" " ++ n ++ " = null;"))

212+ unless (n == "ghc") (hPutStrLn h (" " ++ unPackageName n ++ " = null;"))

215213 hPutStrLn h ""

216214 hPutStrLn h (" # " ++ show (pPrint snapshot) ++ " packages")

217215 forM_ (Map.toList allPackages) $ \(name, v) -> do

218− let pkgId = PackageIdentifier (PackageName name) v

216+ let pkgId = PackageIdentifier name v

219217

220218 isInDefaultPackageSet :: Bool

221219 isInDefaultPackageSet = maybe False (== v) (Map.lookup name generatedDefaultPackageSet)

222220

223221 isInStackage :: Bool

224− isInStackage = isJust (Map.lookup (PackageName name) packages)

222+ isInStackage = isJust (Map.lookup name packages)

225223 case (isInStackage,isInDefaultPackageSet) of

226224 (True,True) -> return () -- build is visible and enabled

227− (True,False) -> hPutStrLn h (" " ++ show name ++ " = doDistribute super." ++ show (mangle pkgId) ++ ";")

228− (False,True) -> hPutStrLn h (" " ++ show name ++ " = dontDistribute super." ++ show name ++ ";")

225+ (True,False) -> hPutStrLn h (" " ++ show (unPackageName name) ++ " = doDistribute super." ++ show (mangle pkgId) ++ ";")

226+ (False,True) -> hPutStrLn h (" " ++ show (unPackageName name) ++ " = dontDistribute super." ++ show (unPackageName name) ++ ";")

229227 (False,False) -> fail ("logic error processing " ++ display pkgId ++ " in " ++ show (pPrint snapshot))

230228 hPutStrLn h ""

231229 hPutStrLn h "}"

@@ -244,18 +242,17 @@ parsePreferredVersionsLine [] = Nothing

244242parsePreferredVersionsLine ('-':'-':_) = Nothing

245243parsePreferredVersionsLine l = simpleParse l `mplus` error ("invalid preferred-versions line: " ++ show l)

246244

247−enforcePreferredVersions :: [Constraint] -> String -> Map Version GenericPackageDescription

248− -> Map Version GenericPackageDescription

249−enforcePreferredVersions cs pkg = Map.filterWithKey (\v _ -> PackageIdentifier (PackageName pkg) v `satisfiesConstraints` cs)

245+enforcePreferredVersions :: [Constraint] -> PackageName -> Set Version -> Set Version

246+enforcePreferredVersions cs pkg = Set.filter (\v -> PackageIdentifier pkg v `satisfiesConstraints` cs)

250247

251248resolveConstraint :: Constraint -> Hackage -> Version

252249resolveConstraint c = fromMaybe (error msg) . resolveConstraint' c

253250 where msg = "constraint " ++ display c ++ " cannot be resolved in Hackage"

254251

255252resolveConstraint' :: Constraint -> Hackage -> Maybe Version

256−resolveConstraint' (Dependency (PackageName name) vrange) hackage

253+resolveConstraint' (Dependency name vrange) hackage

257254 | Just vset' <- Map.lookup name hackage

258− , vset <- Set.filter (`withinRange` vrange) (Map.keysSet vset')

255+ , vset <- Set.filter (`withinRange` vrange) vset'

259256 , not (Set.null vset) = Just (Set.findMax vset)

260257 | otherwise = Nothing

261258