Initial package dump parsing #166

Don't be afraid of the diff size, most of it is GHC dump output for
tests

src/Stack/PackageDump.hs

@@ -0,0 +1,167 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+module Stack.PackageDump
+    ( Line
+    , eachSection
+    , eachPair
+    , DumpPackage (..)
+    , conduitDumpPackage
+    ) where
+
+import Control.Monad.Catch (MonadThrow, Exception, throwM)
+import Control.Monad (when)
+import Stack.Types
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as S
+import Data.Conduit
+import Data.Typeable (Typeable)
+import qualified Data.Conduit.List as CL
+import qualified Data.Conduit.Binary as CB
+import qualified Data.Map as Map
+import Control.Applicative ((<$>), (<*>))
+import Data.Maybe (catMaybes)
+
+-- | Dump information for a single package
+data DumpPackage = DumpPackage
+    { dpGhcPkgId :: !GhcPkgId
+    , dpLibDirs :: ![ByteString]
+    , dpDepends :: ![(GhcPkgId, BuiltinRts)]
+    }
+    deriving (Show, Eq, Ord)
+
+type BuiltinRts = Bool
+
+data PackageDumpException
+    = MissingSingleField ByteString
+    | MissingMultiField ByteString
+    | MismatchedId PackageName Version GhcPkgId
+    deriving (Show, Typeable)
+instance Exception PackageDumpException
+
+-- | Convert a stream of bytes into a stream of @DumpPackage@s
+conduitDumpPackage :: MonadThrow m => Conduit ByteString m DumpPackage
+conduitDumpPackage = (=$= CL.catMaybes) $ eachSection $ do
+    pairs <- eachPair (\k -> (k, ) <$> CL.consume) =$= CL.consume
+    let m = Map.fromList pairs
+    let parseS k =
+            case Map.lookup k m of
+                Just [v] -> return v
+                _ -> throwM $ MissingSingleField k
+        parseM k =
+            case Map.lookup k m of
+                Just vs -> return vs
+                Nothing -> throwM $ MissingMultiField k
+
+        parseDepend "builtin_rts" = return Nothing
+        parseDepend bs =
+            (Just . (, builtinRts)) <$> parseGhcPkgId bs'
+          where
+            (bs', builtinRts) =
+                case stripSuffixBS " builtin_rts" bs of
+                    Nothing ->
+                        case stripPrefixBS "builtin_rts " bs of
+                            Nothing -> (bs, False)
+                            Just x -> (x, True)
+                    Just x -> (x, True)
+    case Map.lookup "id" m of
+        Just ["builtin_rts"] -> return Nothing
+        _ -> do
+            name <- parseS "name" >>= parsePackageName
+            version <- parseS "version" >>= parseVersion
+            ghcPkgId <- parseS "id" >>= parseGhcPkgId
+            when (PackageIdentifier name version /= ghcPkgIdPackageIdentifier ghcPkgId)
+                $ throwM $ MismatchedId name version ghcPkgId
+            libDirs <- parseM "library-dirs"
+            depends <- parseM "depends" >>= mapM parseDepend
+            return $ Just DumpPackage
+                { dpGhcPkgId = ghcPkgId
+                , dpLibDirs = libDirs
+                , dpDepends = catMaybes depends
+                }
+
+stripPrefixBS x y
+    | x `S.isPrefixOf` y = Just $ S.drop (S.length x) y
+    | otherwise = Nothing
+
+stripSuffixBS x y
+    | x `S.isSuffixOf` y = Just $ S.take (S.length y - S.length x) y
+    | otherwise = Nothing
+
+-- | A single line of input, not including line endings
+type Line = ByteString
+
+-- | Apply the given Sink to each section of output, broken by a single line containing ---
+eachSection :: Monad m
+            => Sink Line m a
+            -> Conduit ByteString m a
+eachSection inner =
+    CL.map (S.filter (/= _cr)) =$= CB.lines =$= start
+  where
+    _cr = 13
+
+    start = CL.peek >>= maybe (return ()) (const go)
+
+    go = do
+        x <- toConsumer $ takeWhileC (/= "---") =$= inner
+        yield x
+        CL.drop 1
+        start
+
+-- | Grab each key/value pair
+eachPair :: Monad m
+         => (ByteString -> Sink Line m a)
+         -> Conduit Line m a
+eachPair inner =
+    start
+  where
+    start = await >>= maybe (return ()) start'
+
+    _colon = 58
+    _space = 32
+
+    start' bs1 =
+        toConsumer (valSrc =$= inner key) >>= yield >> start
+      where
+        (key, bs2) = S.breakByte _colon bs1
+        (spaces, bs3) = S.span (== _space) $ S.drop 1 bs2
+        indent = S.length key + 1 + S.length spaces
+
+        valSrc
+            | S.null bs3 = noIndent
+            | otherwise = yield bs3 >> loopIndent indent
+
+    noIndent = do
+        mx <- await
+        case mx of
+            Nothing -> return ()
+            Just bs -> do
+                let (spaces, val) = S.span (== _space) bs
+                if S.length spaces == 0
+                    then leftover val
+                    else do
+                        yield val
+                        loopIndent (S.length spaces)
+
+    loopIndent i =
+        loop
+      where
+        loop = await >>= maybe (return ()) go
+
+        go bs
+            | S.length spaces == i && S.all (== _space) spaces =
+                yield val >> loop
+            | otherwise = leftover bs
+          where
+            (spaces, val) = S.splitAt i bs
+
+-- | General purpose utility
+takeWhileC :: Monad m => (a -> Bool) -> Conduit a m a
+takeWhileC f =
+    loop
+  where
+    loop = await >>= maybe (return ()) go
+
+    go x
+        | f x = yield x >> loop
+        | otherwise = leftover x

src/test/Stack/PackageDumpSpec.hs

@@ -0,0 +1,99 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
+module Stack.PackageDumpSpec where
+
+import Data.Conduit
+import qualified Data.Conduit.List as CL
+import qualified Data.Conduit.Binary as CB
+import Control.Monad.Trans.Resource (runResourceT)
+import Stack.PackageDump
+import Stack.Types
+import Test.Hspec
+
+main :: IO ()
+main = hspec spec
+
+spec :: Spec
+spec = do
+    describe "eachSection" $ do
+        let test name content expected = it name $ do
+                actual <- yield content $$ eachSection CL.consume =$ CL.consume
+                actual `shouldBe` expected
+        test
+            "unix line endings"
+            "foo\nbar\n---\nbaz---\nbin\n---\n"
+            [ ["foo", "bar"]
+            , ["baz---", "bin"]
+            ]
+        test
+            "windows line endings"
+            "foo\r\nbar\r\n---\r\nbaz---\r\nbin\r\n---\r\n"
+            [ ["foo", "bar"]
+            , ["baz---", "bin"]
+            ]
+
+    it "eachPair" $ do
+        let bss =
+                [ "key1: val1"
+                , "key2: val2a"
+                , "      val2b"
+                , "key3:"
+                , "key4:"
+                , "   val4a"
+                , "   val4b"
+                ]
+            sink k = fmap (k, ) CL.consume
+        actual <- mapM_ yield bss $$ eachPair sink =$ CL.consume
+        actual `shouldBe`
+            [ ("key1", ["val1"])
+            , ("key2", ["val2a", "val2b"])
+            , ("key3", [])
+            , ("key4", ["val4a", "val4b"])
+            ]
+
+    describe "conduitDumpPackage" $ do
+        it "ghc 7.8" $ do
+            haskell2010:_ <- runResourceT
+                $ CB.sourceFile "test/package-dump/ghc-7.8.txt"
+               $$ conduitDumpPackage
+               =$ CL.consume
+            ghcPkgId <- parseGhcPkgId "haskell2010-1.1.2.0-05c8dd51009e08c6371c82972d40f55a"
+            depends <- mapM parseGhcPkgId
+                [ "array-0.5.0.0-470385a50d2b78598af85cfe9d988e1b"
+                , "base-4.7.0.2-bfd89587617e381ae01b8dd7b6c7f1c1"
+                , "ghc-prim-0.3.1.0-a24f9c14c632d75b683d0f93283aea37"
+                ]
+            haskell2010 `shouldBe` DumpPackage
+                { dpGhcPkgId = ghcPkgId
+                , dpLibDirs = ["/opt/ghc/7.8.4/lib/ghc-7.8.4/haskell2010-1.1.2.0"]
+                , dpDepends = map (, False) depends
+                }
+
+        it "ghc 7.10" $ do
+            haskell2010:_ <- runResourceT
+                $ CB.sourceFile "test/package-dump/ghc-7.10.txt"
+               $$ conduitDumpPackage
+               =$ CL.consume
+            ghcPkgId <- parseGhcPkgId "ghc-7.10.1-325809317787a897b7a97d646ceaa3a3"
+            depends <- mapM parseGhcPkgId
+                [ "array-0.5.1.0-e29cdbe82692341ebb7ce6e2798294f9"
+                , "base-4.8.0.0-1b689eb8d72c4d4cc88f445839c1f01a"
+                , "bin-package-db-0.0.0.0-708fc7d634a370b311371a5bcde40b62"
+                , "bytestring-0.10.6.0-0909f8f31271f3d75749190bf2ee35db"
+                , "containers-0.5.6.2-2114032c163425cc264e6e1169dc2f6d"
+                , "directory-1.2.2.0-b4959b472d9eee380c6b32291ade29e0"
+                , "filepath-1.4.0.0-40d643aa87258c186441a1f8f3e13ca6"
+                , "hoopl-3.10.0.2-8c8dfc4c3140e5f7c982da224c3cb1f0"
+                , "hpc-0.6.0.2-ac9064885aa8cb08a93314222939ead4"
+                , "process-1.2.3.0-3b1e9bca6ac38225806ff7bbf3f845b1"
+                , "template-haskell-2.10.0.0-e895139a0ffff267d412e3d0191ce93b"
+                , "time-1.5.0.1-e17a9220d438435579d2914e90774246"
+                , "transformers-0.4.2.0-c1a7bb855a176fe475d7b665301cd48f"
+                , "unix-2.7.1.0-e5915eb989e568b732bc7286b0d0817f"
+                ]
+            haskell2010 `shouldBe` DumpPackage
+                { dpGhcPkgId = ghcPkgId
+                , dpLibDirs = ["/opt/ghc/7.10.1/lib/ghc-7.10.1/ghc_EMlWrQ42XY0BNVbSrKixqY"]
+                , dpDepends = map (, False) depends
+                }

stack.cabal

@@ -14,7 +14,7 @@ copyright:           2015 FP Complete
 category:            Development
 build-type:          Simple
 cabal-version:       >=1.10
-extra-source-files:  README.md ARCHITECTURE.md ChangeLog.md
+extra-source-files:  README.md ARCHITECTURE.md ChangeLog.md test/package-dump/*.txt
 
 library
   hs-source-dirs:    src/
@@ -28,6 +28,7 @@ library
                      Stack.Fetch
                      Stack.GhcPkg
                      Stack.Package
+                     Stack.PackageDump
                      Stack.PackageIndex
                      Stack.Setup
                      Stack.Types
@@ -157,6 +158,7 @@ test-suite stack-test
   other-modules:  Spec
                 , Stack.BuildPlanSpec
                 , Stack.ConfigSpec
+                , Stack.PackageDumpSpec
   ghc-options:    -Wall -O2
   extensions:     FlexibleContexts
   build-depends:  base >=4.7 && <5