{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
module Stack.PackageDump
( Line
, eachSection
, eachPair
, DumpPackage (..)
, conduitDumpPackage
, ghcPkgDump
, InstalledCache
, InstalledCacheEntry (..)
, newInstalledCache
, loadInstalledCache
, saveInstalledCache
, addProfiling
, addHaddock
, sinkMatching
, pruneDeps
) where
import Control.Applicative
import Control.Arrow ((&&&))
import Control.Exception.Enclosed (tryIO)
import Control.Monad (liftM)
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Logger (MonadLogger)
import Control.Monad.Trans.Control
import Data.Attoparsec.Args
import Data.Attoparsec.Text as P
import Data.Binary.VersionTagged
import Data.ByteString (ByteString)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import Data.Conduit
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import Data.Either (partitionEithers)
import qualified Data.Foldable as F
import Data.IORef
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (catMaybes)
import qualified Data.Set as Set
import qualified Data.Text.Encoding as T
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import Path
import Path.IO (createTree)
import Prelude
import Stack.GhcPkg
import Stack.Types
import System.Directory (getDirectoryContents, doesFileExist)
import System.Process.Read
newtype InstalledCache = InstalledCache (IORef InstalledCacheInner)
newtype InstalledCacheInner = InstalledCacheInner (Map GhcPkgId InstalledCacheEntry)
deriving (Binary, NFData, Generic)
instance HasStructuralInfo InstalledCacheInner
instance HasSemanticVersion InstalledCacheInner
data InstalledCacheEntry = InstalledCacheEntry
{ installedCacheProfiling :: !Bool
, installedCacheHaddock :: !Bool
, installedCacheIdent :: !PackageIdentifier }
deriving (Eq, Generic)
instance Binary InstalledCacheEntry
instance HasStructuralInfo InstalledCacheEntry
instance NFData InstalledCacheEntry
ghcPkgDump
:: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)
=> EnvOverride
-> WhichCompiler
-> Maybe (Path Abs Dir)
-> Sink ByteString IO a
-> m a
ghcPkgDump menv wc mpkgDb sink = do
F.mapM_ (createDatabase menv wc) mpkgDb
a <- sinkProcessStdout Nothing menv (ghcPkgExeName wc) args sink
return a
where
args = concat
[ case mpkgDb of
Nothing -> ["--global", "--no-user-package-db"]
Just pkgdb -> ["--user", "--no-user-package-db", "--package-db", toFilePath pkgdb]
, ["dump", "--expand-pkgroot"]
]
newInstalledCache :: MonadIO m => m InstalledCache
newInstalledCache = liftIO $ InstalledCache <$> newIORef (InstalledCacheInner Map.empty)
loadInstalledCache :: (MonadLogger m, MonadIO m) => Path Abs File -> m InstalledCache
loadInstalledCache path = do
m <- taggedDecodeOrLoad (toFilePath path) (return $ InstalledCacheInner Map.empty)
liftIO $ fmap InstalledCache $ newIORef m
saveInstalledCache :: MonadIO m => Path Abs File -> InstalledCache -> m ()
saveInstalledCache path (InstalledCache ref) = liftIO $ do
createTree (parent path)
readIORef ref >>= taggedEncodeFile (toFilePath path)
pruneDeps
:: (Ord name, Ord id)
=> (id -> name)
-> (item -> id)
-> (item -> [id])
-> (item -> item -> item)
-> [item]
-> Map name item
pruneDeps getName getId getDepends chooseBest =
Map.fromList
. (map $ \item -> (getName $ getId item, item))
. loop Set.empty Set.empty []
where
loop foundIds usedNames foundItems dps =
case partitionEithers $ map depsMet dps of
([], _) -> foundItems
(s', dps') ->
let foundIds' = Map.fromListWith chooseBest s'
foundIds'' = Set.fromList $ map getId $ Map.elems foundIds'
usedNames' = Map.keysSet foundIds'
foundItems' = Map.elems foundIds'
in loop
(Set.union foundIds foundIds'')
(Set.union usedNames usedNames')
(foundItems ++ foundItems')
(catMaybes dps')
where
depsMet dp
| name `Set.member` usedNames = Right Nothing
| all (`Set.member` foundIds) (getDepends dp) = Left (name, dp)
| otherwise = Right $ Just dp
where
id' = getId dp
name = getName id'
sinkMatching :: Monad m
=> Bool
-> Bool
-> Map PackageName Version
-> Consumer (DumpPackage Bool Bool)
m
(Map PackageName (DumpPackage Bool Bool))
sinkMatching reqProfiling reqHaddock allowed = do
dps <- CL.filter (\dp -> isAllowed (dpPackageIdent dp) &&
(not reqProfiling || dpProfiling dp) &&
(not reqHaddock || dpHaddock dp))
=$= CL.consume
return $ Map.fromList $ map (packageIdentifierName . dpPackageIdent &&& id) $ Map.elems $ pruneDeps
id
dpGhcPkgId
dpDepends
const
dps
where
isAllowed (PackageIdentifier name version) =
case Map.lookup name allowed of
Just version' | version /= version' -> False
_ -> True
addProfiling :: MonadIO m
=> InstalledCache
-> Conduit (DumpPackage a b) m (DumpPackage Bool b)
addProfiling (InstalledCache ref) =
CL.mapM go
where
go dp = liftIO $ do
InstalledCacheInner m <- readIORef ref
let gid = dpGhcPkgId dp
p <- case Map.lookup gid m of
Just installed -> return (installedCacheProfiling installed)
Nothing | null (dpLibraries dp) -> return True
Nothing -> do
let loop [] = return False
loop (dir:dirs) = do
econtents <- tryIO $ getDirectoryContents dir
let contents = either (const []) id econtents
if or [isProfiling content lib
| content <- contents
, lib <- dpLibraries dp
] && not (null contents)
then return True
else loop dirs
loop $ dpLibDirs dp
return dp { dpProfiling = p }
isProfiling :: FilePath
-> ByteString
-> Bool
isProfiling content lib =
prefix `S.isPrefixOf` S8.pack content
where
prefix = S.concat ["lib", lib, "_p"]
addHaddock :: MonadIO m
=> InstalledCache
-> Conduit (DumpPackage a b) m (DumpPackage a Bool)
addHaddock (InstalledCache ref) =
CL.mapM go
where
go dp = liftIO $ do
InstalledCacheInner m <- readIORef ref
let gid = dpGhcPkgId dp
h <- case Map.lookup gid m of
Just installed -> return (installedCacheHaddock installed)
Nothing | not (dpHasExposedModules dp) -> return True
Nothing -> do
let loop [] = return False
loop (ifc:ifcs) = do
exists <- doesFileExist ifc
if exists
then return True
else loop ifcs
loop $ dpHaddockInterfaces dp
return dp { dpHaddock = h }
data DumpPackage profiling haddock = DumpPackage
{ dpGhcPkgId :: !GhcPkgId
, dpPackageIdent :: !PackageIdentifier
, dpLibDirs :: ![FilePath]
, dpLibraries :: ![ByteString]
, dpHasExposedModules :: !Bool
, dpDepends :: ![GhcPkgId]
, dpHaddockInterfaces :: ![FilePath]
, dpProfiling :: !profiling
, dpHaddock :: !haddock
, dpIsExposed :: !Bool
}
deriving (Show, Eq, Ord)
data PackageDumpException
= MissingSingleField ByteString (Map ByteString [Line])
| Couldn'tParseField ByteString [Line]
deriving Typeable
instance Exception PackageDumpException
instance Show PackageDumpException where
show (MissingSingleField name values) = unlines $ concat
[ return $ concat
[ "Expected single value for field name "
, show name
, " when parsing ghc-pkg dump output:"
]
, map (\(k, v) -> " " ++ show (k, v)) (Map.toList values)
]
show (Couldn'tParseField name ls) =
"Couldn't parse the field " ++ show name ++ " from lines: " ++ show ls
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 m
parseM k =
case Map.lookup k m of
Just vs -> vs
Nothing -> []
parseDepend :: MonadThrow m => ByteString -> m (Maybe GhcPkgId)
parseDepend "builtin_rts" = return Nothing
parseDepend bs =
liftM Just $ 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
let libDirKey = "library-dirs"
libraries = parseM "hs-libraries"
exposedModules = parseM "exposed-modules"
exposed = parseM "exposed"
depends <- mapM parseDepend $ parseM "depends"
let parseQuoted key =
case mapM (P.parseOnly (argsParser NoEscaping) . T.decodeUtf8) val of
Left{} -> throwM (Couldn'tParseField key val)
Right dirs -> return (concat dirs)
where
val = parseM key
libDirPaths <- parseQuoted libDirKey
haddockInterfaces <- parseQuoted "haddock-interfaces"
return $ Just DumpPackage
{ dpGhcPkgId = ghcPkgId
, dpPackageIdent = PackageIdentifier name version
, dpLibDirs = libDirPaths
, dpLibraries = S8.words $ S8.unwords libraries
, dpHasExposedModules = not (null libraries || null exposedModules)
, dpDepends = catMaybes (depends :: [Maybe GhcPkgId])
, dpHaddockInterfaces = haddockInterfaces
, dpProfiling = ()
, dpHaddock = ()
, dpIsExposed = exposed == ["True"]
}
stripPrefixBS :: ByteString -> ByteString -> Maybe ByteString
stripPrefixBS x y
| x `S.isPrefixOf` y = Just $ S.drop (S.length x) y
| otherwise = Nothing
stripSuffixBS :: ByteString -> ByteString -> Maybe ByteString
stripSuffixBS x y
| x `S.isSuffixOf` y = Just $ S.take (S.length y - S.length x) y
| otherwise = Nothing
type Line = ByteString
eachSection :: Monad m
=> Sink Line m a
-> Conduit ByteString m a
eachSection inner =
CL.map (S.filter (/= _cr)) =$= CB.lines =$= start
where
_cr = 13
peekBS = await >>= maybe (return Nothing) (\bs ->
if S.null bs
then peekBS
else leftover bs >> return (Just bs))
start = peekBS >>= maybe (return ()) (const go)
go = do
x <- toConsumer $ takeWhileC (/= "---") =$= inner
yield x
CL.drop 1
start
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.break (== _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
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