1{-# LANGUAGE NoImplicitPrelude #-} 2{-# LANGUAGE DataKinds #-} 3{-# LANGUAGE FlexibleContexts #-} 4{-# LANGUAGE OverloadedStrings #-} 5 6-- | Functions for the GHC package database. 7 8module Stack.GhcPkg 9 (getGlobalDB 10 ,findGhcPkgField 11 ,createDatabase 12 ,unregisterGhcPkgIds 13 ,ghcPkgPathEnvVar 14 ,mkGhcPackagePath) 15 where 16 17import Stack.Prelude 18import qualified Data.ByteString.Char8 as S8 19import qualified Data.ByteString.Lazy as BL 20import Data.List 21import qualified Data.Text as T 22import qualified Data.Text.Encoding as T 23import Path (parent, (</>)) 24import Path.Extra (toFilePathNoTrailingSep) 25import Path.IO 26import Stack.Constants 27import Stack.Types.Config (GhcPkgExe (..)) 28import Stack.Types.GhcPkgId 29import Stack.Types.Compiler 30import System.FilePath (searchPathSeparator) 31import RIO.Process 32 33-- | Get the global package database 34getGlobalDB 35 :: (HasProcessContext env, HasLogFunc env) 36 => GhcPkgExe 37 -> RIO env (Path Abs Dir) 38getGlobalDB pkgexe = do 39 logDebug "Getting global package database location" 40 -- This seems like a strange way to get the global package database 41 -- location, but I don't know of a better one 42 bs <- ghcPkg pkgexe [] ["list", "--global"] >>= either throwIO return 43 let fp = S8.unpack $ stripTrailingColon $ firstLine bs 44 liftIO $ resolveDir' fp 45 where 46 stripTrailingColon bs 47 | S8.null bs = bs 48 | S8.last bs == ':' = S8.init bs 49 | otherwise = bs 50 firstLine = S8.takeWhile (\c -> c /= '\r' && c /= '\n') 51 52-- | Run the ghc-pkg executable 53ghcPkg 54 :: (HasProcessContext env, HasLogFunc env) 55 => GhcPkgExe 56 -> [Path Abs Dir] 57 -> [String] 58 -> RIO env (Either SomeException S8.ByteString) 59ghcPkg pkgexe@(GhcPkgExe pkgPath) pkgDbs args = do 60 eres <- go 61 case eres of 62 Left _ -> do 63 mapM_ (createDatabase pkgexe) pkgDbs 64 go 65 Right _ -> return eres 66 where 67 pkg = toFilePath pkgPath 68 go = tryAny $ BL.toStrict . fst <$> proc pkg args' readProcess_ 69 args' = packageDbFlags pkgDbs ++ args 70 71-- | Create a package database in the given directory, if it doesn't exist. 72createDatabase 73 :: (HasProcessContext env, HasLogFunc env) 74 => GhcPkgExe 75 -> Path Abs Dir 76 -> RIO env () 77createDatabase (GhcPkgExe pkgPath) db = do 78 exists <- doesFileExist (db </> relFilePackageCache) 79 unless exists $ do 80 -- ghc-pkg requires that the database directory does not exist 81 -- yet. If the directory exists but the package.cache file 82 -- does, we're in a corrupted state. Check for that state. 83 dirExists <- doesDirExist db 84 args <- if dirExists 85 then do 86 logWarn $ 87 "The package database located at " <> 88 fromString (toFilePath db) <> 89 " is corrupted (missing its package.cache file)." 90 logWarn "Proceeding with a recache" 91 return ["--package-db", toFilePath db, "recache"] 92 else do 93 -- Creating the parent doesn't seem necessary, as ghc-pkg 94 -- seems to be sufficiently smart. But I don't feel like 95 -- finding out it isn't the hard way 96 ensureDir (parent db) 97 return ["init", toFilePath db] 98 void $ proc (toFilePath pkgPath) args $ \pc -> 99 readProcess_ pc `onException` 100 logError ("Unable to create package database at " <> fromString (toFilePath db)) 101 102-- | Get the environment variable to use for the package DB paths. 103ghcPkgPathEnvVar :: WhichCompiler -> Text 104ghcPkgPathEnvVar Ghc = "GHC_PACKAGE_PATH" 105 106-- | Get the necessary ghc-pkg flags for setting up the given package database 107packageDbFlags :: [Path Abs Dir] -> [String] 108packageDbFlags pkgDbs = 109 "--no-user-package-db" 110 : map (\x -> "--package-db=" ++ toFilePath x) pkgDbs 111 112-- | Get the value of a field of the package. 113findGhcPkgField 114 :: (HasProcessContext env, HasLogFunc env) 115 => GhcPkgExe 116 -> [Path Abs Dir] -- ^ package databases 117 -> String -- ^ package identifier, or GhcPkgId 118 -> Text 119 -> RIO env (Maybe Text) 120findGhcPkgField pkgexe pkgDbs name field = do 121 result <- 122 ghcPkg 123 pkgexe 124 pkgDbs 125 ["field", "--simple-output", name, T.unpack field] 126 return $ 127 case result of 128 Left{} -> Nothing 129 Right bs -> 130 fmap (stripCR . T.decodeUtf8) $ listToMaybe $ S8.lines bs 131 132-- | unregister list of package ghcids, batching available from GHC 8.2.1, 133-- see https://github.com/commercialhaskell/stack/issues/2662#issuecomment-460342402 134-- using GHC package id where available (from GHC 7.9) 135unregisterGhcPkgIds 136 :: (HasProcessContext env, HasLogFunc env) 137 => GhcPkgExe 138 -> Path Abs Dir -- ^ package database 139 -> NonEmpty (Either PackageIdentifier GhcPkgId) 140 -> RIO env () 141unregisterGhcPkgIds pkgexe pkgDb epgids = do 142 eres <- ghcPkg pkgexe [pkgDb] args 143 case eres of 144 Left e -> logWarn $ displayShow e 145 Right _ -> return () 146 where 147 (idents, gids) = partitionEithers $ toList epgids 148 args = "unregister" : "--user" : "--force" : 149 map packageIdentifierString idents ++ 150 if null gids then [] else "--ipid" : map ghcPkgIdString gids 151 152-- | Get the value for GHC_PACKAGE_PATH 153mkGhcPackagePath :: Bool -> Path Abs Dir -> Path Abs Dir -> [Path Abs Dir] -> Path Abs Dir -> Text 154mkGhcPackagePath locals localdb deps extras globaldb = 155 T.pack $ intercalate [searchPathSeparator] $ concat 156 [ [toFilePathNoTrailingSep localdb | locals] 157 , [toFilePathNoTrailingSep deps] 158 , [toFilePathNoTrailingSep db | db <- reverse extras] 159 , [toFilePathNoTrailingSep globaldb] 160 ] 161