{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Functions for the GHC package database.

module Stack.GhcPkg
  (getGlobalDB
  ,findGhcPkgField
  ,createDatabase
  ,unregisterGhcPkgIds
  ,ghcPkgPathEnvVar
  ,mkGhcPackagePath)
  where

import           Stack.Prelude
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as BL
import           Data.List
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import           Path (parent, (</>))
import           Path.Extra (toFilePathNoTrailingSep)
import           Path.IO
import           Stack.Constants
import           Stack.Types.Config (GhcPkgExe (..))
import           Stack.Types.GhcPkgId
import           Stack.Types.Compiler
import           System.FilePath (searchPathSeparator)
import           RIO.Process

-- | Get the global package database
getGlobalDB
  :: (HasProcessContext env, HasLogFunc env)
  => GhcPkgExe
  -> RIO env (Path Abs Dir)
getGlobalDB :: GhcPkgExe -> RIO env (Path Abs Dir)
getGlobalDB GhcPkgExe
pkgexe = do
    Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Getting global package database location"
    -- This seems like a strange way to get the global package database
    -- location, but I don't know of a better one
    ByteString
bs <- GhcPkgExe
-> [Path Abs Dir]
-> [String]
-> RIO env (Either SomeException ByteString)
forall env.
(HasProcessContext env, HasLogFunc env) =>
GhcPkgExe
-> [Path Abs Dir]
-> [String]
-> RIO env (Either SomeException ByteString)
ghcPkg GhcPkgExe
pkgexe [] [String
"list", String
"--global"] RIO env (Either SomeException ByteString)
-> (Either SomeException ByteString -> RIO env ByteString)
-> RIO env ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SomeException -> RIO env ByteString)
-> (ByteString -> RIO env ByteString)
-> Either SomeException ByteString
-> RIO env ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> RIO env ByteString
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ByteString -> RIO env ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return
    let fp :: String
fp = ByteString -> String
S8.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
stripTrailingColon (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
firstLine ByteString
bs
    IO (Path Abs Dir) -> RIO env (Path Abs Dir)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Path Abs Dir) -> RIO env (Path Abs Dir))
-> IO (Path Abs Dir) -> RIO env (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ String -> IO (Path Abs Dir)
forall (m :: * -> *). MonadIO m => String -> m (Path Abs Dir)
resolveDir' String
fp
  where
    stripTrailingColon :: ByteString -> ByteString
stripTrailingColon ByteString
bs
        | ByteString -> Bool
S8.null ByteString
bs = ByteString
bs
        | ByteString -> Char
S8.last ByteString
bs Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':' = ByteString -> ByteString
S8.init ByteString
bs
        | Bool
otherwise = ByteString
bs
    firstLine :: ByteString -> ByteString
firstLine = (Char -> Bool) -> ByteString -> ByteString
S8.takeWhile (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n')

-- | Run the ghc-pkg executable
ghcPkg
  :: (HasProcessContext env, HasLogFunc env)
  => GhcPkgExe
  -> [Path Abs Dir]
  -> [String]
  -> RIO env (Either SomeException S8.ByteString)
ghcPkg :: GhcPkgExe
-> [Path Abs Dir]
-> [String]
-> RIO env (Either SomeException ByteString)
ghcPkg pkgexe :: GhcPkgExe
pkgexe@(GhcPkgExe Path Abs File
pkgPath) [Path Abs Dir]
pkgDbs [String]
args = do
    Either SomeException ByteString
eres <- RIO env (Either SomeException ByteString)
go
    case Either SomeException ByteString
eres of
      Left SomeException
_ -> do
        (Path Abs Dir -> RIO env ()) -> [Path Abs Dir] -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (GhcPkgExe -> Path Abs Dir -> RIO env ()
forall env.
(HasProcessContext env, HasLogFunc env) =>
GhcPkgExe -> Path Abs Dir -> RIO env ()
createDatabase GhcPkgExe
pkgexe) [Path Abs Dir]
pkgDbs
        RIO env (Either SomeException ByteString)
go
      Right ByteString
_ -> Either SomeException ByteString
-> RIO env (Either SomeException ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return Either SomeException ByteString
eres
  where
    pkg :: String
pkg = Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
pkgPath
    go :: RIO env (Either SomeException ByteString)
go = RIO env ByteString -> RIO env (Either SomeException ByteString)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (RIO env ByteString -> RIO env (Either SomeException ByteString))
-> RIO env ByteString -> RIO env (Either SomeException ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.toStrict (ByteString -> ByteString)
-> ((ByteString, ByteString) -> ByteString)
-> (ByteString, ByteString)
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst ((ByteString, ByteString) -> ByteString)
-> RIO env (ByteString, ByteString) -> RIO env ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> [String]
-> (ProcessConfig () () () -> RIO env (ByteString, ByteString))
-> RIO env (ByteString, ByteString)
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
String -> [String] -> (ProcessConfig () () () -> m a) -> m a
proc String
pkg [String]
args' ProcessConfig () () () -> RIO env (ByteString, ByteString)
forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ByteString, ByteString)
readProcess_
    args' :: [String]
args' = [Path Abs Dir] -> [String]
packageDbFlags [Path Abs Dir]
pkgDbs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
args

-- | Create a package database in the given directory, if it doesn't exist.
createDatabase
  :: (HasProcessContext env, HasLogFunc env)
  => GhcPkgExe
  -> Path Abs Dir
  -> RIO env ()
createDatabase :: GhcPkgExe -> Path Abs Dir -> RIO env ()
createDatabase (GhcPkgExe Path Abs File
pkgPath) Path Abs Dir
db = do
    Bool
exists <- Path Abs File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist (Path Abs Dir
db Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFilePackageCache)
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
        -- ghc-pkg requires that the database directory does not exist
        -- yet. If the directory exists but the package.cache file
        -- does, we're in a corrupted state. Check for that state.
        Bool
dirExists <- Path Abs Dir -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist Path Abs Dir
db
        [String]
args <- if Bool
dirExists
            then do
                Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
                    Utf8Builder
"The package database located at " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                    String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath Path Abs Dir
db) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                    Utf8Builder
" is corrupted (missing its package.cache file)."
                Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"Proceeding with a recache"
                [String] -> RIO env [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
"--package-db", Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath Path Abs Dir
db, String
"recache"]
            else do
                -- Creating the parent doesn't seem necessary, as ghc-pkg
                -- seems to be sufficiently smart. But I don't feel like
                -- finding out it isn't the hard way
                Path Abs Dir -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (Path Abs Dir -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs Dir
db)
                [String] -> RIO env [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
"init", Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath Path Abs Dir
db]
        RIO env (ByteString, ByteString) -> RIO env ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (RIO env (ByteString, ByteString) -> RIO env ())
-> RIO env (ByteString, ByteString) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ String
-> [String]
-> (ProcessConfig () () () -> RIO env (ByteString, ByteString))
-> RIO env (ByteString, ByteString)
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
String -> [String] -> (ProcessConfig () () () -> m a) -> m a
proc (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
pkgPath) [String]
args ((ProcessConfig () () () -> RIO env (ByteString, ByteString))
 -> RIO env (ByteString, ByteString))
-> (ProcessConfig () () () -> RIO env (ByteString, ByteString))
-> RIO env (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ \ProcessConfig () () ()
pc ->
          ProcessConfig () () () -> RIO env (ByteString, ByteString)
forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ByteString, ByteString)
readProcess_ ProcessConfig () () ()
pc RIO env (ByteString, ByteString)
-> RIO env () -> RIO env (ByteString, ByteString)
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`onException`
          Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder
"Unable to create package database at " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath Path Abs Dir
db))

-- | Get the environment variable to use for the package DB paths.
ghcPkgPathEnvVar :: WhichCompiler -> Text
ghcPkgPathEnvVar :: WhichCompiler -> Text
ghcPkgPathEnvVar WhichCompiler
Ghc = Text
"GHC_PACKAGE_PATH"

-- | Get the necessary ghc-pkg flags for setting up the given package database
packageDbFlags :: [Path Abs Dir] -> [String]
packageDbFlags :: [Path Abs Dir] -> [String]
packageDbFlags [Path Abs Dir]
pkgDbs =
          String
"--no-user-package-db"
        String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (Path Abs Dir -> String) -> [Path Abs Dir] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\Path Abs Dir
x -> String
"--package-db=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath Path Abs Dir
x) [Path Abs Dir]
pkgDbs

-- | Get the value of a field of the package.
findGhcPkgField
    :: (HasProcessContext env, HasLogFunc env)
    => GhcPkgExe
    -> [Path Abs Dir] -- ^ package databases
    -> String -- ^ package identifier, or GhcPkgId
    -> Text
    -> RIO env (Maybe Text)
findGhcPkgField :: GhcPkgExe
-> [Path Abs Dir] -> String -> Text -> RIO env (Maybe Text)
findGhcPkgField GhcPkgExe
pkgexe [Path Abs Dir]
pkgDbs String
name Text
field = do
    Either SomeException ByteString
result <-
        GhcPkgExe
-> [Path Abs Dir]
-> [String]
-> RIO env (Either SomeException ByteString)
forall env.
(HasProcessContext env, HasLogFunc env) =>
GhcPkgExe
-> [Path Abs Dir]
-> [String]
-> RIO env (Either SomeException ByteString)
ghcPkg
            GhcPkgExe
pkgexe
            [Path Abs Dir]
pkgDbs
            [String
"field", String
"--simple-output", String
name, Text -> String
T.unpack Text
field]
    Maybe Text -> RIO env (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> RIO env (Maybe Text))
-> Maybe Text -> RIO env (Maybe Text)
forall a b. (a -> b) -> a -> b
$
        case Either SomeException ByteString
result of
            Left{} -> Maybe Text
forall a. Maybe a
Nothing
            Right ByteString
bs ->
                (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text
stripCR (Text -> Text) -> (ByteString -> Text) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8) (Maybe ByteString -> Maybe Text) -> Maybe ByteString -> Maybe Text
forall a b. (a -> b) -> a -> b
$ [ByteString] -> Maybe ByteString
forall a. [a] -> Maybe a
listToMaybe ([ByteString] -> Maybe ByteString)
-> [ByteString] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
S8.lines ByteString
bs

-- | unregister list of package ghcids, batching available from GHC 8.2.1,
-- see https://github.com/commercialhaskell/stack/issues/2662#issuecomment-460342402
-- using GHC package id where available (from GHC 7.9)
unregisterGhcPkgIds
  :: (HasProcessContext env, HasLogFunc env)
  => GhcPkgExe
  -> Path Abs Dir -- ^ package database
  -> NonEmpty (Either PackageIdentifier GhcPkgId)
  -> RIO env ()
unregisterGhcPkgIds :: GhcPkgExe
-> Path Abs Dir
-> NonEmpty (Either PackageIdentifier GhcPkgId)
-> RIO env ()
unregisterGhcPkgIds GhcPkgExe
pkgexe Path Abs Dir
pkgDb NonEmpty (Either PackageIdentifier GhcPkgId)
epgids = do
    Either SomeException ByteString
eres <- GhcPkgExe
-> [Path Abs Dir]
-> [String]
-> RIO env (Either SomeException ByteString)
forall env.
(HasProcessContext env, HasLogFunc env) =>
GhcPkgExe
-> [Path Abs Dir]
-> [String]
-> RIO env (Either SomeException ByteString)
ghcPkg GhcPkgExe
pkgexe [Path Abs Dir
pkgDb] [String]
args
    case Either SomeException ByteString
eres of
        Left SomeException
e -> Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ SomeException -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow SomeException
e
        Right ByteString
_ -> () -> RIO env ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    ([PackageIdentifier]
idents, [GhcPkgId]
gids) = [Either PackageIdentifier GhcPkgId]
-> ([PackageIdentifier], [GhcPkgId])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either PackageIdentifier GhcPkgId]
 -> ([PackageIdentifier], [GhcPkgId]))
-> [Either PackageIdentifier GhcPkgId]
-> ([PackageIdentifier], [GhcPkgId])
forall a b. (a -> b) -> a -> b
$ NonEmpty (Either PackageIdentifier GhcPkgId)
-> [Either PackageIdentifier GhcPkgId]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (Either PackageIdentifier GhcPkgId)
epgids
    args :: [String]
args = String
"unregister" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"--user" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"--force" String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
        (PackageIdentifier -> String) -> [PackageIdentifier] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PackageIdentifier -> String
packageIdentifierString [PackageIdentifier]
idents [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
        if [GhcPkgId] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GhcPkgId]
gids then [] else String
"--ipid" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (GhcPkgId -> String) -> [GhcPkgId] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map GhcPkgId -> String
ghcPkgIdString [GhcPkgId]
gids

-- | Get the value for GHC_PACKAGE_PATH
mkGhcPackagePath :: Bool -> Path Abs Dir -> Path Abs Dir -> [Path Abs Dir] -> Path Abs Dir -> Text
mkGhcPackagePath :: Bool
-> Path Abs Dir
-> Path Abs Dir
-> [Path Abs Dir]
-> Path Abs Dir
-> Text
mkGhcPackagePath Bool
locals Path Abs Dir
localdb Path Abs Dir
deps [Path Abs Dir]
extras Path Abs Dir
globaldb =
  String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate [Char
searchPathSeparator] ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [Path Abs Dir -> String
forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
localdb | Bool
locals]
    , [Path Abs Dir -> String
forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
deps]
    , [Path Abs Dir -> String
forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
db | Path Abs Dir
db <- [Path Abs Dir] -> [Path Abs Dir]
forall a. [a] -> [a]
reverse [Path Abs Dir]
extras]
    , [Path Abs Dir -> String
forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
globaldb]
    ]