@@ -1,101 +1,68 @@
1−{-# LANGUAGE DeriveGeneric #-}
21{-# LANGUAGE OverloadedStrings #-}
32
43module Cabal2Nix.HackageGit ( Hackage, readHackage, module Data.Map ) where
54
6−import Control.DeepSeq.Generics
7−import GHC.Generics ( Generic )
85import Control.Monad
96import Data.Aeson
107import Data.ByteString.Char8 ( ByteString )
11−import qualified Data.ByteString.Char8 as BS8 ( readFile )
8+import qualified Data.ByteString.Char8 as BS
129import Data.ByteString.Lazy.Char8 ( fromStrict )
1310import Data.Digest.Pure.SHA ( sha256, showDigest )
11+import Data.List ( foldl' )
1412import Data.Map
1513import Data.Maybe ( fromMaybe )
1614import Data.String.UTF8 ( toString, fromRep )
17−import Data.Version
18−import Distribution.Package
1915import Distribution.PackageDescription
2016import Distribution.PackageDescription.Parse ( parsePackageDescription, ParseResult(..) )
21−import Distribution.Text ( simpleParse, display )
17+import Distribution.Text ( simpleParse )
18+import Distribution.Version ( Version )
2219import System.Directory
2320import System.FilePath
24−import Control.Monad.Par.Combinator
25−import Control.Monad.Par.IO
26−import Control.Monad.Trans ( liftIO )
27−
28−-- | A 'Map' representation of the Hackage database. Every package name
29−-- maps to a non-empty set of version, and for every version there is a
30−-- Cabal file stored as a (lazy) 'ByteString'.
21+import System.IO.Unsafe
3122
3223type Hackage = Map String (Map Version GenericPackageDescription)
3324
25+readHackage :: FilePath -> IO Hackage
26+readHackage path = do db <- getSubDirs path >>= foldM discoverPackageVersions empty
27+ return $ mapWithKey (\pkg -> Data.List.foldl' (makeVersionMap pkg) empty) db
28+ 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
55+
3456getSubDirs :: FilePath -> IO [FilePath]
3557getSubDirs path = do
3658 let isDirectory p = doesDirectoryExist (path </> p)
3759 getDirectoryContents path >>= filterM isDirectory . Prelude.filter (\x -> head x /= '.')
3860
39−-- | Read the Hackage database from the given 'FilePath' and return a
40−-- 'Hackage' map that provides fast access to its contents.
41−
42−readHackage :: FilePath -> IO Hackage
43−readHackage root = runParIO $ do
44− pkglist <- liftIO $ getSubDirs root
45− hackage' <- parMapM (readHackagePackage root) $!! pkglist
46− let hackage = [ (pkg, Data.Map.mapWithKey (mkPkgDescr pkg) version2buf) | (pkg, version2buf) <- hackage' ]
47−
48− mkPkgDescr :: String -> Version -> (ByteString, Meta) -> GenericPackageDescription
49− mkPkgDescr pkg v (buf,meta) = cabal { packageDescription = pd { customFieldsPD = cf } }
50− where
51− cabal = parsePackage pkg v buf
52− pd = packageDescription cabal
53− cf = customFieldsPD pd ++ ("X-Cabal-File-Hash", mkSHA256 buf)
54− : [ ("X-Package-" ++ k, v') | (k,v') <- toList (hashes meta) ]
55−
56− mkSHA256 :: ByteString -> String
57− mkSHA256 = showDigest . sha256 . fromStrict
58−
59− return (fromList hackage)
60−
61−readHackagePackage :: FilePath -> FilePath -> ParIO (FilePath, Map Version (ByteString,Meta))
62−readHackagePackage root pkg = do
63− versions <- liftIO $ getSubDirs (root </> pkg)
64− x <- parMapM (readHackagePackageVersion root pkg) $!! versions
65− return (pkg, fromList x)
66−
67−readHackagePackageVersion :: FilePath -> FilePath -> FilePath -> ParIO (Version, (ByteString,Meta))
68−readHackagePackageVersion root pkg version = do
69− let v = pVersion version
70− cabal <- liftIO $ BS8.readFile (root </> pkg </> version </> pkg <.> "cabal")
71− meta <- liftIO (BS8.readFile (root </> pkg </> version </> pkg <.> "json"))
72− return (v, (cabal,parseMeta pkg v meta))
73−
74−pVersion :: String -> Version
75−pVersion str = fromMaybe (error $ "hackage-db: cannot parse version " ++ show str) (simpleParse str)
76−
77−-- | Convenience wrapper around 'parsePackage'' to parse a single Cabal
78−-- file. Failure is reported with 'error'.
79−
80−parsePackage :: String -> Version -> ByteString -> GenericPackageDescription
81−parsePackage name version buf = case parsePackage' buf of
82− Right a -> a
83− Left err -> error $ "cannot parse cabal package " ++ show name ++ "-" ++ display version ++ ": " ++ err
84−
85−-- | Parse a single Cabal file.
86−
87−parsePackage' :: ByteString -> Either String GenericPackageDescription
88−parsePackage' buf = case parsePackageDescription (decodeUTF8 buf) of
89− ParseOk _ a -> Right a
90− ParseFailed err -> Left (show err)
91− where
92− decodeUTF8 :: ByteString -> String
93− decodeUTF8 = toString . fromRep
61+mkSHA256 :: ByteString -> String
62+mkSHA256 = showDigest . sha256 . fromStrict
9463
9564data Meta = Meta { hashes :: Map String String {-, locations :: [String], pkgsize :: Int-} }
96− deriving (Show, Generic)
97−
98−instance NFData Meta where rnf = genericRnf
65+ deriving (Show)
9966
10067instance FromJSON Meta where
10168 parseJSON (Object v) = Meta <$>
@@ -105,10 +72,8 @@ instance FromJSON Meta where
10572 -- A non-Object value is of the wrong type, so fail.
10673 parseJSON _ = mzero
10774
108−parseMeta :: String -> Version -> ByteString -> Meta
75+parseMeta :: String -> String -> ByteString -> Meta
10976parseMeta pkg version buf =
11077 case eitherDecodeStrict buf of
111− Left msg -> error $ "hackage-db: cannot decode JSON meta data for " ++ display pkgid ++ ":" ++ msg
78+ Left msg -> error $ "hackage-db: cannot decode JSON meta data for " ++ pkg ++ "-" ++ version ++ ":" ++ msg
11279 Right x -> x
113− where
114− pkgid = PackageIdentifier (PackageName pkg) version