diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,27 @@ +# Revision history for hackage-db + +## 2.1.3 + +* `hackageTarball` / `cabalStateDir` now support overriding the cabal directory + location by setting the `CABAL_DIR` environment variable. This is useful if + `hackage-db` doesn't detect the correct location on its own: + + - A matching cabal state directory may exist, but should not be used for some + reason. + + - A non-standard cabal state directory may be used, but `hackage-db` can't + find it (as it doesn't check the `cabal-install` configuration file). + +* `hackageTarball` now supports all state dir location(s) (newly) supported by + `cabal-install`. If `CABAL_DIR` is not set, it will look in the following + locations in that order: + + 1. `$HOME/.cabal`, the classic location, will be preferred if it exists. + 2. `$XDG_CACHE_HOME/cabal` (usually `$HOME/.cache/cabal`) is used otherwise. + `cabal-install` 3.10.1.0 and newer will default to this location for + fresh installations. + +## 2.1.2 + +Fix a bug which lead to `parsePackageData` always failing if the package had +a `preferred-versions` file in the hackage tarball. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,7 @@ +hackage-db +========== + +[![hackage release](https://img.shields.io/hackage/v/hackage-db.svg?label=hackage)](http://hackage.haskell.org/package/hackage-db) +[![stackage LTS package](http://stackage.org/package/hackage-db/badge/lts)](http://stackage.org/lts/package/hackage-db) +[![stackage Nightly package](http://stackage.org/package/hackage-db/badge/nightly)](http://stackage.org/nightly/package/hackage-db) +![Continous Integration](https://github.com/NixOS/cabal2nix/workflows/Haskell-CI/badge.svg) diff --git a/example/list-known-versions.hs b/example/list-known-versions.hs new file mode 100644 --- /dev/null +++ b/example/list-known-versions.hs @@ -0,0 +1,17 @@ +module Main ( main ) where + +import Distribution.Hackage.DB.Path +import Distribution.Hackage.DB.Unparsed + +import Control.Monad +import qualified Data.ByteString as BS +import Data.List as List +import Data.Map as Map +import Distribution.Text + +main :: IO () +main = do + db <- hackageTarball >>= readTarball Nothing + forM_ (toList db) $ \(pn, PackageData vr vs) -> do + let pref = if BS.null vr then "" else " (preferred: " ++ show vr ++ ")" + putStrLn $ display pn ++ ": " ++ intercalate ", " (fmap display (keys vs)) ++ pref diff --git a/example/show-meta-data.hs b/example/show-meta-data.hs new file mode 100644 --- /dev/null +++ b/example/show-meta-data.hs @@ -0,0 +1,21 @@ +module Main ( main ) where + +import Distribution.Hackage.DB.Path +import Distribution.Hackage.DB.Unparsed +import Distribution.Hackage.DB.Utility + +import Control.Monad +import Data.ByteString.UTF8 as BS +import Data.Map as Map +import Distribution.Package +import System.Environment + +main :: IO () +main = do + packageIds <- getArgs + db <- hackageTarball >>= readTarball Nothing + forM_ packageIds $ \pid -> do + let PackageIdentifier pn v = parseText "PackageIdentifier" pid + putStrLn $ maybe ("*** unknown package identifier on Hackage: " ++ show pid) + (toString . metaFile) + (Map.lookup pn db >>= Map.lookup v . versions) diff --git a/example/show-package-versions.hs b/example/show-package-versions.hs new file mode 100644 --- /dev/null +++ b/example/show-package-versions.hs @@ -0,0 +1,17 @@ +module Main ( main ) where + +import Distribution.Hackage.DB + +import Control.Monad ( forM_ ) +import Data.Map as Map +import Distribution.Package +import Distribution.Text ( display ) +import System.Environment ( getArgs ) + +main :: IO () +main = do + db <- hackageTarball >>= readTarball Nothing + pkgs <- getArgs + forM_ pkgs $ \pkg -> do + let vs = maybe [] Map.keys (Map.lookup (mkPackageName pkg) db) + putStrLn $ pkg ++ ": " ++ unwords (fmap display vs) diff --git a/hackage-db.cabal b/hackage-db.cabal --- a/hackage-db.cabal +++ b/hackage-db.cabal @@ -1,57 +1,85 @@ -Name: hackage-db -Version: 1.22 -Copyright: Peter Simons -License: BSD3 -License-File: LICENSE -Author: Peter Simons -Maintainer: Peter Simons -Homepage: http://github.com/peti/hackage-db -Category: Distribution -Synopsis: access Hackage's package database via Data.Map -Cabal-Version: >= 1.6 -Build-Type: Simple -Tested-With: GHC >= 6.10.4 && <= 7.8.4 -Description: - This module provides simple access to the Hackage database by means - of @Data.Map@. Suppose you wanted to implement a utility that queries - the set of available versions for a given package, the following - program would do the trick: - . - > import qualified Distribution.Hackage.DB as DB - > import Distribution.Text ( display ) - > import System.Environment ( getArgs ) - > - > main :: IO () - > main = do - > pkgs <- getArgs - > db <- DB.readHackage - > let getVersions name = maybe [] DB.keys (DB.lookup name db) - > mapM_ (putStrLn . unwords . map display . getVersions) pkgs - . - When run, it would produce the following output: - . - > ./a.out containers deepseq cabal-install - > 0.1.0.0 0.1.0.1 0.2.0.0 0.2.0.1 0.3.0.0 0.4.0.0 - > 1.0.0.0 1.1.0.0 1.1.0.1 1.1.0.2 - > 0.4.0 0.5.0 0.5.1 0.5.2 0.6.0 0.6.2 0.6.4 0.8.0 0.8.2 0.10.0 0.10.2 - . - Note that once the database has been parsed, it can be accessed - quickly, but the inital cost of reading @00-index.tar@ is fairly - high. - . - This package is known to work on Linux and Mac OS X, but it's - probably not going to work on Windows (because no-one tested it, as - far as I know). +name: hackage-db +version: 2.1.3 +synopsis: Access cabal-install's Hackage database via Data.Map +description: This library provides convenient access to the local copy of the Hackage + database that \"cabal update\" creates. Check out + for a collection + of simple example programs that demonstrate how to use this code. +license: BSD3 +license-file: LICENSE +author: Peter Simons, Alexander Altman, Ben James, Kevin Quick +maintainer: sternenseemann +tested-with: GHC == 8.8.4 || == 8.10.7 || == 9.0.2 || == 9.2.7 || == 9.4.4 +category: Distribution +homepage: https://github.com/NixOS/cabal2nix/tree/master/hackage-db#readme +bug-reports: https://github.com/NixOS/cabal2nix/issues +build-type: Simple +cabal-version: >= 1.10 +extra-source-files: README.md + CHANGELOG.md -Source-Repository head - Type: git - Location: git://github.com/peti/hackage-db.git +source-repository head + type: git + location: git://github.com/NixOS/cabal2nix.git + subdir: hackage-db -Library - Build-Depends: base >= 3 && < 5, tar >= 0.4, Cabal, containers, - directory, filepath, bytestring, utf8-string - hs-source-dirs: src - Exposed-Modules: Distribution.Hackage.DB.Unparsed - Distribution.Hackage.DB.Parsed - Distribution.Hackage.DB.Path - Distribution.Hackage.DB +flag install-examples + default: False + description: Build and install example programs. + +library + exposed-modules: Distribution.Hackage.DB + Distribution.Hackage.DB.Builder + Distribution.Hackage.DB.Errors + Distribution.Hackage.DB.MetaData + Distribution.Hackage.DB.Parsed + Distribution.Hackage.DB.Path + Distribution.Hackage.DB.Unparsed + Distribution.Hackage.DB.Utility + other-modules: Paths_hackage_db + hs-source-dirs: src + build-depends: base >= 4.9 && < 5 + , Cabal > 3 + , aeson + , bytestring + , containers + , directory + , exceptions + , filepath + , tar >= 0.4 + , time + , utf8-string + default-language: Haskell2010 + other-extensions: DeriveDataTypeable + DeriveGeneric + +executable list-known-versions + main-is: list-known-versions.hs + hs-source-dirs: example + default-language: Haskell2010 + + if flag(install-examples) + build-depends: base >= 3 && < 5, Cabal, bytestring, containers, hackage-db + else + buildable: False + +executable show-meta-data + main-is: show-meta-data.hs + hs-source-dirs: example + default-language: Haskell2010 + + if flag(install-examples) + build-depends: base >= 3 && < 5, Cabal, containers, hackage-db, utf8-string + else + buildable: False + +executable show-package-versions + main-is: show-package-versions.hs + hs-source-dirs: example + default-language: Haskell2010 + other-extensions: CPP + + if flag(install-examples) + build-depends: base >= 3 && < 5, Cabal, containers, hackage-db + else + buildable: False diff --git a/src/Distribution/Hackage/DB.hs b/src/Distribution/Hackage/DB.hs --- a/src/Distribution/Hackage/DB.hs +++ b/src/Distribution/Hackage/DB.hs @@ -1,26 +1,14 @@ {- | - Module : Distribution.Hackage.DB - License : BSD3 - Maintainer : simons@cryp.to - Stability : provisional - Portability : portable - - This module provides simple access to the Hackage database by means - of 'Map'. + Maintainer: simons@cryp.to + Stability: provisional + Portability: portable -} module Distribution.Hackage.DB - ( Hackage, readHackage, readHackage', parseHackage, hackagePath - , module Data.Map - , module Data.Version - , module Distribution.Package - , module Distribution.PackageDescription + ( HackageDB, PackageData, VersionData(..) + , readTarball, parseTarball, hackageTarball ) where -import Data.Map -import Data.Version import Distribution.Hackage.DB.Parsed import Distribution.Hackage.DB.Path -import Distribution.Package -import Distribution.PackageDescription diff --git a/src/Distribution/Hackage/DB/Builder.hs b/src/Distribution/Hackage/DB/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Hackage/DB/Builder.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE BangPatterns #-} + +{- | + Maintainer: simons@cryp.to + Stability: provisional + Portability: portable + -} + +module Distribution.Hackage.DB.Builder + ( readTarball, parseTarball + , Builder(..) + ) + where + +import Distribution.Hackage.DB.Errors +import Distribution.Hackage.DB.Utility + +import Codec.Archive.Tar as Tar +import Codec.Archive.Tar.Entry as Tar +import Control.Monad.Catch +import qualified Data.ByteString.Lazy as BSL +import Distribution.Types.PackageName +import Distribution.Types.Version +import System.FilePath + +readTarball :: FilePath -> IO (Entries FormatError) +readTarball = fmap Tar.read . BSL.readFile + +data Builder m a = Builder + { insertPreferredVersions :: PackageName -> EpochTime -> BSL.ByteString -> a -> m a + , insertCabalFile :: PackageName -> Version -> EpochTime -> BSL.ByteString -> a -> m a + , insertMetaFile :: PackageName -> Version -> EpochTime -> BSL.ByteString -> a -> m a + } + +{-# INLINABLE parseTarball #-} +parseTarball :: MonadThrow m => Builder m a -> Maybe EpochTime -> Entries FormatError -> a -> m a +parseTarball b (Just et) (Next e es) !db = if entryTime e > et then return db else insertEntry b e db >>= parseTarball b (Just et) es +parseTarball b Nothing (Next e es) !db = insertEntry b e db >>= parseTarball b Nothing es +parseTarball _ _ (Fail err) _ = throwM err +parseTarball _ _ Done !db = return db + +{-# INLINABLE insertEntry #-} +insertEntry :: MonadThrow m => Builder m a -> Entry -> a -> m a +insertEntry b e db = + case (splitDirectories (entryPath e), entryContent e) of + ([pn,"preferred-versions"], NormalFile buf _) -> insertPreferredVersions b (mkPackageName pn) (entryTime e) buf db + ([pn,v,file], NormalFile buf _) + | takeExtension file == ".cabal" -> insertCabalFile b (mkPackageName pn) (parseText "Version" v) (entryTime e) buf db + | takeExtension file == ".json" -> insertMetaFile b (mkPackageName pn) (parseText "Version" v) (entryTime e) buf db + _ -> throwM (UnsupportedTarEntry e) diff --git a/src/Distribution/Hackage/DB/Errors.hs b/src/Distribution/Hackage/DB/Errors.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Hackage/DB/Errors.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +{- | + Maintainer: simons@cryp.to + Stability: provisional + Portability: portable + -} + +module Distribution.Hackage.DB.Errors where + +import Codec.Archive.Tar +import Control.Exception +import Data.Typeable ( Typeable ) +import Distribution.Package +import Distribution.Version + +data HackageDBTarball a = HackageDBTarball FilePath a deriving (Show, Typeable) +instance (Show a, Typeable a) => Exception (HackageDBTarball a) + +data HackageDBPackageName a = HackageDBPackageName PackageName a deriving (Show, Typeable) +instance (Show a, Typeable a) => Exception (HackageDBPackageName a) + +data HackageDBPackageVersion a = HackageDBPackageVersion Version a deriving (Show, Typeable) +instance (Show a, Typeable a) => Exception (HackageDBPackageVersion a) + +newtype IncorrectTarfile = IncorrectTarfile FormatError deriving (Show, Typeable) +instance Exception IncorrectTarfile + +newtype UnsupportedTarEntry = UnsupportedTarEntry Entry deriving (Show, Typeable) +instance Exception UnsupportedTarEntry + +newtype InvalidMetaFile = InvalidMetaFile String deriving (Show, Typeable) +instance Exception InvalidMetaFile + +newtype InvalidCabalFile = InvalidCabalFile String deriving (Show, Typeable) +instance Exception InvalidCabalFile + +data InvalidRepresentationOfType = InvalidRepresentationOfType String String deriving (Show, Typeable) +instance Exception InvalidRepresentationOfType + +data NoHackageTarballFound = NoHackageTarballFound deriving (Show, Typeable) +instance Exception NoHackageTarballFound diff --git a/src/Distribution/Hackage/DB/MetaData.hs b/src/Distribution/Hackage/DB/MetaData.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Hackage/DB/MetaData.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE DeriveGeneric #-} + +{- | + Maintainer: simons@cryp.to + Stability: provisional + Portability: portable + + Types and class instances for parsing the @package.json@ files found in a + @01-index.tar@ tarball from Hackage with "Data.Aeson". These parsers mirror + the exact structure of those files, but only a small part of it is actually + of interest to anyone other than implementors of @cabal-install@. Everyone + else will most likely prefer the functions oferred by + "Distribution.Hackage.DB.Parsed". + -} + +module Distribution.Hackage.DB.MetaData where + +import Distribution.Hackage.DB.Errors + +import Control.Exception +import Data.Aeson +import Data.ByteString.Lazy.UTF8 as BS +import Data.Map as Map +import GHC.Generics ( Generic ) + +-- | Parse the @package.json@ file found in a @01-index.tar@ tarball from +-- Hackage with "Data.Aeson". This function is a convenience wrapper around +-- 'eitherDecode' that throws an 'InvalidMetaFile' exception to signal failure. +-- +-- >>> :set -XOverloadedStrings +-- >>> parseMetaData "{\"signatures\":[],\"signed\":{\"_type\":\"Targets\",\"expires\":null,\"targets\":{\"/package/jailbreak-cabal-1.3.2.tar.gz\":{\"hashes\":{\"md5\":\"ba42b3e68323ccbeb3ac900cd68f9e90\",\"sha256\":\"212a8bbc3dfc748c4063282414a2726709d651322f3984c9989179d2352950f4\"},\"length\":2269}},\"version\":0}}" +-- MetaData {signed = SignedMetaData {version = 0, expires = Nothing, _type = "Targets", targets = fromList [("/package/jailbreak-cabal-1.3.2.tar.gz",TargetData {length = 2269, hashes = fromList [("md5","ba42b3e68323ccbeb3ac900cd68f9e90"),("sha256","212a8bbc3dfc748c4063282414a2726709d651322f3984c9989179d2352950f4")]})]}, signatures = []} + +parseMetaData :: ByteString -> MetaData +parseMetaData = either (throw . InvalidMetaFile) id . eitherDecode + +data MetaData = MetaData { signed :: SignedMetaData + , signatures :: [String] + } + deriving (Show, Generic) + +instance FromJSON MetaData + +data SignedMetaData = SignedMetaData { version :: Int + , expires :: Maybe String + , _type :: String + , targets :: Map String TargetData + } + deriving (Show, Generic) + +instance FromJSON SignedMetaData + +data TargetData = TargetData { length :: Int + , hashes :: Map String String + } + deriving (Show, Generic) + +instance FromJSON TargetData diff --git a/src/Distribution/Hackage/DB/Parsed.hs b/src/Distribution/Hackage/DB/Parsed.hs --- a/src/Distribution/Hackage/DB/Parsed.hs +++ b/src/Distribution/Hackage/DB/Parsed.hs @@ -1,75 +1,76 @@ -{- | - Module : Distribution.Hackage.DB.Parsed - License : BSD3 - Maintainer : simons@cryp.to - Stability : provisional - Portability : portable +{-# LANGUAGE DeriveGeneric #-} - This module provides simple access to the Hackage database by means - of 'Map'. +{- | + Maintainer: simons@cryp.to + Stability: provisional + Portability: portable -} -module Distribution.Hackage.DB.Parsed - ( Hackage, readHackage, readHackage', parseHackage - , parseUnparsedHackage - , parsePackage, parsePackage' - ) - where - -import Data.ByteString.Lazy.Char8 ( ByteString ) -import Data.Map -import Data.String.UTF8 ( toString, fromRep ) -import Data.Version -import qualified Distribution.Hackage.DB.Unparsed as Unparsed -import Distribution.PackageDescription -import Distribution.PackageDescription.Parse ( parsePackageDescription, ParseResult(..) ) -import Distribution.Text ( display ) - --- | A 'Map' representation of the Hackage database. Every package name --- maps to a non-empty set of version, and for every version there is a --- parsed Cabal file. +module Distribution.Hackage.DB.Parsed where -type Hackage = Map String (Map Version GenericPackageDescription) +import Distribution.Hackage.DB.Errors +import qualified Distribution.Hackage.DB.MetaData as U +import qualified Distribution.Hackage.DB.Unparsed as U +import Distribution.Hackage.DB.Utility --- | Read the Hackage database from the location determined by 'hackagePath' --- and return a 'Map' that provides fast access to its contents. +import Codec.Archive.Tar +import Codec.Archive.Tar.Entry +import Control.Exception +import Control.Monad.Catch +import Data.ByteString as BSS +import Data.ByteString.Lazy as BSL +import Data.ByteString.UTF8 as BSS +import Data.Map as Map +import Data.Maybe +import Data.Time.Clock +import Distribution.Package +import Distribution.PackageDescription +import Distribution.PackageDescription.Parsec +import Distribution.Text +import Distribution.Types.PackageVersionConstraint +import Distribution.Version +import GHC.Generics ( Generic ) -readHackage :: IO Hackage -readHackage = fmap parseUnparsedHackage Unparsed.readHackage +type HackageDB = Map PackageName PackageData --- | Read the Hackage database from the given 'FilePath' and return a --- 'Hackage' map that provides fast access to its contents. +type PackageData = Map Version VersionData -readHackage' :: FilePath -> IO Hackage -readHackage' = fmap parseUnparsedHackage . Unparsed.readHackage' +data VersionData = VersionData { cabalFile :: !GenericPackageDescription + , tarballHashes :: !(Map String String) + } + deriving (Show, Eq, Generic) --- | Parse the contents of Hackage's @00-index.tar@ into a 'Hackage' map. +readTarball :: Maybe UTCTime -> FilePath -> IO HackageDB +readTarball snapshot tarball = fmap parseDB (U.readTarball snapshot tarball) -parseHackage :: ByteString -> Hackage -parseHackage = parseUnparsedHackage . Unparsed.parseHackage +parseTarball :: MonadThrow m => Maybe UTCTime -> Entries FormatError -> m HackageDB +parseTarball snapshot es = fmap parseDB (U.parseTarball snapshot es mempty) --- | Convert an 'Unparsed.Hackage' map into a parsed 'Hackage' map. +parseDB :: U.HackageDB -> HackageDB +parseDB = Map.mapWithKey parsePackageData -parseUnparsedHackage :: Unparsed.Hackage -> Hackage -parseUnparsedHackage = Data.Map.mapWithKey parsePackages +parsePackageData :: PackageName -> U.PackageData -> PackageData +parsePackageData pn (U.PackageData pv vs') = + mapException (\e -> HackageDBPackageName pn (e :: SomeException)) $ + Map.mapWithKey (parseVersionData pn) $ + Map.filterWithKey (\v _ -> v `withinRange` vr) vs' where - parsePackages :: String -> Map Version ByteString -> Map Version GenericPackageDescription - parsePackages name = Data.Map.mapWithKey (parsePackage name) - --- | Convenience wrapper around 'parsePackage'' to parse a single Cabal --- file. Failure is reported with 'error'. - -parsePackage :: String -> Version -> ByteString -> GenericPackageDescription -parsePackage name version buf = case parsePackage' buf of - Right a -> a - Left err -> error $ "cannot parse cabal package " ++ show name ++ "-" ++ display version ++ ": " ++ err + PackageVersionConstraint _ vr + | BSS.null pv = PackageVersionConstraint pn anyVersion + | otherwise = parseText "preferred version range" (toString pv) --- | Parse a single Cabal file. +parseVersionData :: PackageName -> Version -> U.VersionData -> VersionData +parseVersionData pn v (U.VersionData cf m) = + mapException (\e -> HackageDBPackageVersion v (e :: SomeException)) $ + VersionData gpd (parseMetaData pn v m) + where + gpd = fromMaybe (throw (InvalidCabalFile (show (pn,v)))) $ + parseGenericPackageDescriptionMaybe cf -parsePackage' :: ByteString -> Either String GenericPackageDescription -parsePackage' buf = case parsePackageDescription (decodeUTF8 buf) of - ParseOk _ a -> Right a - ParseFailed err -> Left (show err) +parseMetaData :: PackageName -> Version -> BSS.ByteString -> Map String String +parseMetaData pn v buf | BSS.null buf = Map.empty + | otherwise = maybe Map.empty U.hashes targetData where - decodeUTF8 :: ByteString -> String - decodeUTF8 = toString . fromRep + targets = U.targets (U.signed (U.parseMetaData (BSL.fromStrict buf))) + target = "/package/" ++ display pn ++ "-" ++ display v ++ ".tar.gz" + targetData = Map.lookup target targets diff --git a/src/Distribution/Hackage/DB/Path.hs b/src/Distribution/Hackage/DB/Path.hs --- a/src/Distribution/Hackage/DB/Path.hs +++ b/src/Distribution/Hackage/DB/Path.hs @@ -9,16 +9,68 @@ @cabal update@. -} -module Distribution.Hackage.DB.Path ( hackagePath ) where +module Distribution.Hackage.DB.Path where -import System.Directory ( getAppUserDataDirectory ) -import System.FilePath ( joinPath ) +import Distribution.Hackage.DB.Errors --- | Determine the default path of the Hackage database, which typically --- resides at @"$HOME\/.cabal\/packages\/hackage.haskell.org\/00-index.tar"@. --- Running the command @"cabal update"@ will keep that file up-to-date. +import Control.Exception +import System.Directory +import System.Environment (lookupEnv) +import System.FilePath -hackagePath :: IO FilePath -hackagePath = do - cabalDir <- getAppUserDataDirectory "cabal" - return $ joinPath [cabalDir, "packages", "hackage.haskell.org", "00-index.tar"] +-- | +-- Determines the /state/ directory (which e.g. holds the hackage tarball) +-- cabal-install uses via the following logic: +-- +-- 1. If the @CABAL_DIR@ environment variable is set, its content is used as the +-- cabal state directory +-- 2. If @~/.cabal@ (see 'getAppUserDataDirectory') exists, use that. +-- 3. Otherwise, use @${XDG_CACHE_HOME}/cabal@ (see @'getXdgDirectory' 'XdgCache'@) +-- which is the new directory cabal-install can use starting with +-- version @3.10.*@. +-- +-- This logic is mostly equivalent to what upstream cabal-install is +-- [doing](https://github.com/haskell/cabal/blob/0ed12188525335ac9759dc957d49979ab09382a1/cabal-install/src/Distribution/Client/Config.hs#L594-L610) +-- with the following exception: +-- The state directory can freely be configured to use a different location +-- in the cabal-install configuration file. hackage-db doesn't parse this +-- configuration file, so differing state directories are ignored. +cabalStateDir :: IO FilePath +cabalStateDir = do + envCabal <- lookupEnv "CABAL_DIR" + dotCabal <- getAppUserDataDirectory "cabal" + dotCabalExists <- doesDirectoryExist dotCabal + case envCabal of + Just dir -> pure dir + Nothing -> + if dotCabalExists + then pure dotCabal + else getXdgDirectory XdgCache "cabal" + +cabalTarballDir :: String -> IO FilePath +cabalTarballDir repo = do + csd <- cabalStateDir + return $ joinPath [csd, "packages", repo] + +hackageTarballDir :: IO FilePath +hackageTarballDir = cabalTarballDir "hackage.haskell.org" + +-- | Determine the default path of the Hackage database, which typically +-- resides in @$HOME\/.cabal\/packages\/hackage.haskell.org\/@. +-- Running the command @cabal update@ or @cabal v2-update@ will keep the index +-- up-to-date. +-- +-- See 'cabalStateDir' on how @hackage-db@ searches for the cabal state directory. +hackageTarball :: IO FilePath +hackageTarball = do + htd <- hackageTarballDir + let idx00 = htd "00-index.tar" + idx01 = htd "01-index.tar" + -- Using 'msum' here would be nice, but unfortunetaly there was no reliable + -- MonadPlus instance for IO in pre 8.x versions of GHC. So we use the ugly + -- code for sake of portability. + have01 <- doesFileExist idx01 + if have01 then return idx01 else do + have00 <- doesFileExist idx00 + if have00 then return idx00 else + throwIO NoHackageTarballFound diff --git a/src/Distribution/Hackage/DB/Unparsed.hs b/src/Distribution/Hackage/DB/Unparsed.hs --- a/src/Distribution/Hackage/DB/Unparsed.hs +++ b/src/Distribution/Hackage/DB/Unparsed.hs @@ -1,62 +1,69 @@ -{- | - Module : Distribution.Hackage.DB.Unparsed - License : BSD3 - Maintainer : simons@cryp.to - Stability : provisional - Portability : portable +{-# LANGUAGE DeriveGeneric #-} - This module provides simple access to the Hackage database by means - of 'Map'. +{- | + Maintainer: simons@cryp.to + Stability: provisional + Portability: portable -} module Distribution.Hackage.DB.Unparsed - ( Hackage, readHackage, readHackage', parseHackage, hackagePath + ( HackageDB, PackageData(..), VersionData(..) + , readTarball, parseTarball + , builder ) where -import qualified Codec.Archive.Tar as Tar -import Data.ByteString.Lazy.Char8 ( ByteString ) -import qualified Data.ByteString.Lazy.Char8 as BS8 ( readFile ) -import Data.Map -import Data.Maybe ( fromMaybe ) -import Data.Version -import Distribution.Hackage.DB.Path -import Distribution.Text ( simpleParse ) -import System.FilePath ( splitDirectories ) +import qualified Distribution.Hackage.DB.Builder as Build +import Distribution.Hackage.DB.Builder ( Builder(..) ) +import Distribution.Hackage.DB.Utility --- | A 'Map' representation of the Hackage database. Every package name --- maps to a non-empty set of version, and for every version there is a --- Cabal file stored as a (lazy) 'ByteString'. +import Codec.Archive.Tar as Tar +import Codec.Archive.Tar.Entry as Tar +import Control.Exception +import Control.Monad.Catch +import Data.ByteString ( ByteString ) +import Data.ByteString.Lazy ( toStrict ) +import Data.Map.Strict as Map +import Data.Time.Clock +import Distribution.Types.PackageName +import Distribution.Types.Version +import GHC.Generics ( Generic ) +import System.FilePath -type Hackage = Map String (Map Version ByteString) +type HackageDB = Map PackageName PackageData --- | Read the Hackage database from the location determined by 'hackagePath' --- and return a 'Map' that provides fast access to its contents. +data PackageData = PackageData { preferredVersions :: !ByteString + , versions :: !(Map Version VersionData) + } + deriving (Show, Eq, Generic) -readHackage :: IO Hackage -readHackage = hackagePath >>= readHackage' +data VersionData = VersionData { cabalFile :: !ByteString + , metaFile :: !ByteString + } + deriving (Show, Eq, Generic) --- | Read the Hackage database from the given 'FilePath' and return a --- 'Hackage' map that provides fast access to its contents. +readTarball :: Maybe UTCTime -> FilePath -> IO HackageDB +readTarball snapshot tarball = Build.readTarball tarball >>= \es -> parseTarball snapshot es mempty -readHackage' :: FilePath -> IO Hackage -readHackage' = fmap parseHackage . BS8.readFile +parseTarball :: MonadThrow m => Maybe UTCTime -> Entries FormatError -> HackageDB -> m HackageDB +parseTarball = Build.parseTarball builder . fmap toEpochTime --- | Parse the contents of Hackage's @00-index.tar@ into a 'Hackage' map. +builder :: Applicative m => Builder m HackageDB +builder = Builder + { insertPreferredVersions = \pn _ buf -> let new = PackageData (toStrict buf) mempty + f _ old = old { preferredVersions = preferredVersions new } + in pure . Map.insertWith f pn new -parseHackage :: ByteString -> Hackage -parseHackage = Tar.foldEntries addEntry empty (error . show) . Tar.read - where - addEntry :: Tar.Entry -> Hackage -> Hackage - addEntry e db = case splitDirectories (Tar.entryPath e) of - [".",".","@LongLink"] -> db - path@[name,vers,_] -> case Tar.entryContent e of - Tar.NormalFile buf _ -> add name vers buf db - _ -> error ("Hackage.DB.parseHackage: unexpected content type for " ++ show path) - _ -> db + , insertCabalFile = \pn v _ buf -> let f Nothing = PackageData mempty (Map.singleton v new) + f (Just pd) = pd { versions = Map.insertWith g v new (versions pd) } + new = VersionData (toStrict buf) mempty + g _ old = old { cabalFile = cabalFile new } + in pure . Map.alter (Just . f) pn - add :: String -> String -> ByteString -> Hackage -> Hackage - add name version pkg = insertWith union name (singleton (pVersion version) pkg) + , insertMetaFile = \pn v _ buf -> let f Nothing = PackageData mempty (Map.singleton v new) + f (Just pd) = pd { versions = Map.insertWith g v new (versions pd) } - pVersion :: String -> Version - pVersion str = fromMaybe (error $ "Hackage.DB.parseHackage: cannot parse version " ++ show str) (simpleParse str) + new = VersionData mempty (toStrict buf) + g _ old = old { metaFile = metaFile new } + in pure . Map.alter (Just . f) pn + } diff --git a/src/Distribution/Hackage/DB/Utility.hs b/src/Distribution/Hackage/DB/Utility.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Hackage/DB/Utility.hs @@ -0,0 +1,45 @@ +{- | + Maintainer : simons@cryp.to + Stability : provisional + Portability : portable + -} + +module Distribution.Hackage.DB.Utility where + +import Distribution.Hackage.DB.Errors + +import Codec.Archive.Tar.Entry as Tar +import Control.Exception +import Control.Monad.Fail +import Data.Maybe +import Data.Time.Clock +import Data.Time.Clock.POSIX +import Data.Time.Format +import Distribution.Parsec + +parseText :: Parsec a => String -> String -> a +parseText t x = fromMaybe (throw (InvalidRepresentationOfType t x)) (simpleParsec x) + +-- | Convert the the 'EpochTime' used by the @tar@ library into a standard +-- 'UTCTime' type. + +fromEpochTime :: EpochTime -> UTCTime +fromEpochTime et = posixSecondsToUTCTime (realToFrac et) + +-- | Convert the standard 'UTCTime' type into the 'EpochTime' used by the @tar@ +-- library. + +toEpochTime :: UTCTime -> EpochTime +toEpochTime = floor . utcTimeToPOSIXSeconds + +-- | Parse an UTC timestamp in extended ISO8601 format a standard 'UTCTime' +-- type. This function is useful to parse the "snapshot" identifier printed by +-- @cabal-install@ after a database update into a useable type. Combine with +-- 'toEpochTime' to obtain an 'EpochTime' that can be passed to the Hackage DB +-- reading code from this library. +-- +-- >>> parseIso8601 "2018-12-21T13:17:40Z" +-- 2018-12-21 13:17:40 UTC + +parseIso8601 :: MonadFail m => String -> m UTCTime +parseIso8601 = parseTimeM False defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%SZ"))