@@ -0,0 +1,102 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module Cabal2Nix.HackageGit ( Hackage, readHackage, module Data.Map ) where
4+
5+import Data.ByteString.Char8 ( ByteString )
6+import qualified Data.ByteString.Char8 as BS8 ( readFile )
7+import Data.ByteString.Lazy.Char8 ( fromStrict )
8+import Data.Map
9+import Data.Aeson
10+import Data.Maybe ( fromMaybe )
11+import Data.Version
12+import Distribution.Text ( simpleParse )
13+import System.FilePath
14+import System.Directory
15+import Control.Monad
16+import Distribution.Package
17+import Distribution.PackageDescription
18+import Distribution.PackageDescription.Parse ( parsePackageDescription, ParseResult(..) )
19+import Distribution.Text ( display )
20+import Data.String.UTF8 ( toString, fromRep )
21+import Data.Digest.Pure.SHA ( sha256, showDigest )
22+
23+-- | A 'Map' representation of the Hackage database. Every package name
24+-- maps to a non-empty set of version, and for every version there is a
25+-- Cabal file stored as a (lazy) 'ByteString'.
26+
27+type Hackage = Map String (Map Version GenericPackageDescription)
28+
29+getSubDirs :: FilePath -> IO [FilePath]
30+getSubDirs path = do
31+ let isDirectory p = doesDirectoryExist (path </> p)
32+ getDirectoryContents path >>= filterM isDirectory . Prelude.filter (\x -> head x /= '.')
33+
34+-- | Read the Hackage database from the given 'FilePath' and return a
35+-- 'Hackage' map that provides fast access to its contents.
36+
37+readHackage :: FilePath -> IO Hackage
38+readHackage root = do
39+ pkglist <- getSubDirs root
40+ x <- mapM (readHackagePackage root) pkglist
41+ return (fromList x)
42+
43+readHackagePackage :: FilePath -> FilePath -> IO (FilePath, Map Version GenericPackageDescription)
44+readHackagePackage root pkg = do
45+ versions <- getSubDirs (root </> pkg)
46+ x <- mapM (readHackagePackageVersion root pkg) versions
47+ return (pkg, fromList x)
48+
49+readHackagePackageVersion :: FilePath -> FilePath -> FilePath -> IO (Version, GenericPackageDescription)
50+readHackagePackageVersion root pkg version = do
51+ let v = pVersion version
52+ buf <- BS8.readFile (root </> pkg </> version </> pkg <.> "cabal")
53+ let cabal = parsePackage pkg v buf
54+ meta <- parseMeta pkg v <$> BS8.readFile (root </> pkg </> version </> pkg <.> "json")
55+ let pd = packageDescription cabal
56+ cf = customFieldsPD pd ++ ("X-Cabal-File-Hash", mkSHA256 buf)
57+ : [ ("X-Package-" ++ k, v') | (k,v') <- toList (hashes meta) ]
58+ cabal' = cabal { packageDescription = pd { customFieldsPD = cf } }
59+ return (v, cabal')
60+
61+pVersion :: String -> Version
62+pVersion str = fromMaybe (error $ "hackage-db: cannot parse version " ++ show str) (simpleParse str)
63+
64+-- | Convenience wrapper around 'parsePackage'' to parse a single Cabal
65+-- file. Failure is reported with 'error'.
66+
67+parsePackage :: String -> Version -> ByteString -> GenericPackageDescription
68+parsePackage name version buf = case parsePackage' buf of
69+ Right a -> a
70+ Left err -> error $ "cannot parse cabal package " ++ show name ++ "-" ++ display version ++ ": " ++ err
71+
72+-- | Parse a single Cabal file.
73+
74+parsePackage' :: ByteString -> Either String GenericPackageDescription
75+parsePackage' buf = case parsePackageDescription (decodeUTF8 buf) of
76+ ParseOk _ a -> Right a
77+ ParseFailed err -> Left (show err)
78+ where
79+ decodeUTF8 :: ByteString -> String
80+ decodeUTF8 = toString . fromRep
81+
82+data Meta = Meta { hashes :: Map String String {-, locations :: [String], pkgsize :: Int-} }
83+ deriving Show
84+
85+instance FromJSON Meta where
86+ parseJSON (Object v) = Meta <$>
87+ v .: "package-hashes" {- <*>
88+ v .: "package-locations" <*>
89+ v .: "package-size" -}
90+ -- A non-Object value is of the wrong type, so fail.
91+ parseJSON _ = mzero
92+
93+parseMeta :: String -> Version -> ByteString -> Meta
94+parseMeta pkg version buf =
95+ case eitherDecodeStrict buf of
96+ Left msg -> error $ "hackage-db: cannot decode JSON meta data for " ++ display pkgid ++ ":" ++ msg
97+ Right x -> x
98+ where
99+ pkgid = PackageIdentifier (PackageName pkg) version
100+
101+mkSHA256 :: ByteString -> String
102+mkSHA256 = showDigest . sha256 . fromStrict