{-# 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 :: forall env.
(HasProcessContext env, HasLogFunc env) =>
GhcPkgExe -> RIO env (Path Abs Dir)
getGlobalDB GhcPkgExe
pkgexe = do
    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 <- forall env.
(HasProcessContext env, HasLogFunc env) =>
GhcPkgExe
-> [Path Abs Dir]
-> [String]
-> RIO env (Either SomeException ByteString)
ghcPkg GhcPkgExe
pkgexe [] [String
"list", String
"--global"] forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall (m :: * -> *) a. Monad m => a -> m a
return
    let fp :: String
fp = ByteString -> String
S8.unpack forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
stripTrailingColon forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
firstLine ByteString
bs
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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 forall a. Eq a => a -> a -> Bool
== Char
':' = HasCallStack => ByteString -> ByteString
S8.init ByteString
bs
        | Bool
otherwise = ByteString
bs
    firstLine :: ByteString -> ByteString
firstLine = (Char -> Bool) -> ByteString -> ByteString
S8.takeWhile (\Char
c -> Char
c forall a. Eq a => a -> a -> Bool
/= Char
'\r' Bool -> Bool -> Bool
&& Char
c 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 :: forall env.
(HasProcessContext env, HasLogFunc env) =>
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
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (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
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Either SomeException ByteString
eres
  where
    pkg :: String
pkg = forall b t. Path b t -> String
toFilePath Path Abs File
pkgPath
    go :: RIO env (Either SomeException ByteString)
go = forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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' 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 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 :: forall env.
(HasProcessContext env, HasLogFunc env) =>
GhcPkgExe -> Path Abs Dir -> RIO env ()
createDatabase (GhcPkgExe Path Abs File
pkgPath) Path Abs Dir
db = do
    Bool
exists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist (Path Abs Dir
db forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFilePackageCache)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists 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 <- forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist Path Abs Dir
db
        [String]
args <- if Bool
dirExists
            then do
                forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$
                    Utf8Builder
"The package database located at " forall a. Semigroup a => a -> a -> a
<>
                    forall a. IsString a => String -> a
fromString (forall b t. Path b t -> String
toFilePath Path Abs Dir
db) forall a. Semigroup a => a -> a -> a
<>
                    Utf8Builder
" is corrupted (missing its package.cache file)."
                forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"Proceeding with a recache"
                forall (m :: * -> *) a. Monad m => a -> m a
return [String
"--package-db", 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

                forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (forall b t. Path b t -> Path b Dir
parent Path Abs Dir
db)
                forall (m :: * -> *) a. Monad m => a -> m a
return [String
"init", forall b t. Path b t -> String
toFilePath Path Abs Dir
db]
        forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
String -> [String] -> (ProcessConfig () () () -> m a) -> m a
proc (forall b t. Path b t -> String
toFilePath Path Abs File
pkgPath) [String]
args forall a b. (a -> b) -> a -> b
$ \ProcessConfig () () ()
pc ->
          forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ByteString, ByteString)
readProcess_ ProcessConfig () () ()
pc forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`onException`
          forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder
"Unable to create package database at " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (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"
        forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (\Path Abs Dir
x -> String
"--package-db=" forall a. [a] -> [a] -> [a]
++ 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 :: forall env.
(HasProcessContext env, HasLogFunc env) =>
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 <-
        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]
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
        case Either SomeException ByteString
result of
            Left{} -> forall a. Maybe a
Nothing
            Right ByteString
bs ->
                forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text
stripCR forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8) forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
listToMaybe 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 :: forall env.
(HasProcessContext env, HasLogFunc env) =>
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 <- 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 -> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> Utf8Builder
displayShow SomeException
e
        Right ByteString
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    ([PackageIdentifier]
idents, [GhcPkgId]
gids) = forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (Either PackageIdentifier GhcPkgId)
epgids
    args :: [String]
args = String
"unregister" forall a. a -> [a] -> [a]
: String
"--user" forall a. a -> [a] -> [a]
: String
"--force" forall a. a -> [a] -> [a]
:
        forall a b. (a -> b) -> [a] -> [b]
map PackageIdentifier -> String
packageIdentifierString [PackageIdentifier]
idents forall a. [a] -> [a] -> [a]
++
        if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GhcPkgId]
gids then [] else String
"--ipid" forall a. a -> [a] -> [a]
: 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 forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
intercalate [Char
searchPathSeparator] forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
localdb | Bool
locals]
    , [forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
deps]
    , [forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
db | Path Abs Dir
db <- forall a. [a] -> [a]
reverse [Path Abs Dir]
extras]
    , [forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
globaldb]
    ]