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