From 658a52b6358c7546dae720b7c552133374edb31c Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 4 Dec 2014 14:08:04 +0200 Subject: [PATCH] PackageIndex --- Stackage2/PackageIndex.hs | 96 ++++++++++++++++++++++++++++++ Stackage2/Prelude.hs | 6 +- stackage.cabal | 3 + test/Stackage2/PackageIndexSpec.hs | 9 +++ 4 files changed, 111 insertions(+), 3 deletions(-) create mode 100644 Stackage2/PackageIndex.hs create mode 100644 test/Stackage2/PackageIndexSpec.hs diff --git a/Stackage2/PackageIndex.hs b/Stackage2/PackageIndex.hs new file mode 100644 index 00000000..bd5ccbe6 --- /dev/null +++ b/Stackage2/PackageIndex.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ViewPatterns #-} +-- | Dealing with the 00-index file and all its cabal files. +module Stackage2.PackageIndex + ( sourcePackageIndex + ) where + +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Archive.Tar.Entry as TarEntry +import Data.Conduit.Lazy (MonadActive, + lazyConsume) +import qualified Data.Text as T +import Distribution.PackageDescription (GenericPackageDescription) +import Distribution.PackageDescription.Parse (ParseResult (..), + parsePackageDescription) +import Distribution.ParseUtils (PError) +import Stackage2.Prelude +import System.Directory (getAppUserDataDirectory) + +-- | Name of the 00-index.tar downloaded from Hackage. +getPackageIndexPath :: MonadIO m => m FilePath +getPackageIndexPath = liftIO $ do + c <- getCabalRoot + configLines <- runResourceT $ sourceFile (c "config") + $$ decodeUtf8C + =$ linesUnboundedC + =$ concatMapC getRemoteCache + =$ sinkList + case configLines of + [x] -> return $ x "hackage.haskell.org" "00-index.tar" + [] -> error $ "No remote-repo-cache found in Cabal config file" + _ -> error $ "Multiple remote-repo-cache entries found in Cabal config file" + where + getCabalRoot :: IO FilePath + getCabalRoot = fpFromString <$> getAppUserDataDirectory "cabal" + + getRemoteCache s = do + ("remote-repo-cache", stripPrefix ":" -> Just v) <- Just $ break (== ':') s + Just $ fpFromText $ T.strip v + +data UnparsedCabalFile = UnparsedCabalFile + { ucfName :: PackageName + , ucfVersion :: Version + , ucfParse :: forall m. MonadThrow m => m GenericPackageDescription + } + +sourcePackageIndex :: (MonadThrow m, MonadResource m, MonadActive m, MonadBaseControl IO m) + => Producer m UnparsedCabalFile +sourcePackageIndex = do + fp <- getPackageIndexPath + -- yay for the tar package. Use lazyConsume instead of readFile to get some + -- kind of resource protection + lbs <- lift $ fromChunks <$> lazyConsume (sourceFile fp) + loop (Tar.read lbs) + where + loop (Tar.Next e es) = goE e >> loop es + loop Tar.Done = return () + loop (Tar.Fail e) = throwM e + + goE e + | Just front <- stripSuffix ".cabal" $ pack $ Tar.entryPath e + , Tar.NormalFile lbs _size <- Tar.entryContent e = do + (name, version) <- parseNameVersion front + yield UnparsedCabalFile + { ucfName = name + , ucfVersion = version + , ucfParse = goContent (Tar.entryPath e) lbs + } + | otherwise = return () + + goContent fp lbs = + case parsePackageDescription $ unpack $ decodeUtf8 lbs of + ParseFailed e -> throwM $ CabalParseException (fpFromString fp) e + ParseOk _warnings gpd -> return gpd + + parseNameVersion t1 = do + let (p', t2) = break (== '/') t1 + p <- simpleParse p' + t3 <- maybe (throwM $ InvalidCabalPath t1 "no slash") return + $ stripPrefix "/" t2 + let (v', t4) = break (== '/') t3 + v <- simpleParse v' + when (t4 /= cons '/' p') $ throwM $ InvalidCabalPath t1 $ "Expected at end: " ++ p' + return (p, v) + +data InvalidCabalPath = InvalidCabalPath Text Text + deriving (Show, Typeable) +instance Exception InvalidCabalPath + +data CabalParseException = CabalParseException FilePath PError + deriving (Show, Typeable) +instance Exception CabalParseException diff --git a/Stackage2/Prelude.hs b/Stackage2/Prelude.hs index 85d2ea79..1fe3dc2e 100644 --- a/Stackage2/Prelude.hs +++ b/Stackage2/Prelude.hs @@ -28,7 +28,7 @@ simpleParse :: (MonadThrow m, DT.Text a, Typeable a, MonoFoldable text, Element => text -> m a simpleParse orig = withTypeRep $ \rep -> case DT.simpleParse str of - Nothing -> throwM (ParseFailed rep (pack str)) + Nothing -> throwM (ParseFailedException rep (pack str)) Just v -> return v where str = unpack orig @@ -42,9 +42,9 @@ simpleParse orig = withTypeRep $ \rep -> unwrap :: m a -> a unwrap _ = error "unwrap" -data ParseFailed = ParseFailed TypeRep Text +data ParseFailedException = ParseFailedException TypeRep Text deriving (Show, Typeable) -instance Exception ParseFailed +instance Exception ParseFailedException data ProcessExitedUnsuccessfully = ProcessExitedUnsuccessfully CreateProcess ExitCode deriving Typeable diff --git a/stackage.cabal b/stackage.cabal index 9f85609f..9efc9ba7 100644 --- a/stackage.cabal +++ b/stackage.cabal @@ -34,6 +34,7 @@ library Stackage2.Prelude Stackage2.ProposedPlan Stackage2.CorePackages + Stackage2.PackageIndex build-depends: base >= 4 && < 5 , containers , Cabal >= 1.14 @@ -51,6 +52,7 @@ library , conduit-extra , classy-prelude-conduit , text + , system-fileio executable stackage default-language: Haskell2010 @@ -66,6 +68,7 @@ test-suite spec hs-source-dirs: test main-is: Spec.hs other-modules: Stackage2.CorePackagesSpec + Stackage2.PackageIndexSpec build-depends: base , stackage , hspec diff --git a/test/Stackage2/PackageIndexSpec.hs b/test/Stackage2/PackageIndexSpec.hs new file mode 100644 index 00000000..8dcf1df9 --- /dev/null +++ b/test/Stackage2/PackageIndexSpec.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-} +module Stackage2.PackageIndexSpec (spec) where + +import Stackage2.PackageIndex +import Stackage2.Prelude +import Test.Hspec + +spec :: Spec +spec = it "works" $ (runResourceT $ sourcePackageIndex $$ sinkNull :: IO ())